XL 2016 inserer des formes avec textes

[chingilou]

bonjour
j'ai un tableau a 3 colonnes N° - Désignation et Quantité
le tableau s’étend de A10 à A196 (variable)
je voudrais créer une macro qui me créera dans la feuille2 des formes (rectangles a coins arrondis H:1.5cm L:6cm) avec comme données textes A1&"--"&B1&"--("&y&"/"C1&")"
y de 1 à C1
le but finale c'est d'imprimer la feuille2 sur un autocollant, couper les formes et les coller sur les boites (pour plus de clarté pour la livraison)

N°	désig	Qté
1	article 01	2
2	article 02	3
3	article 03	2

j’espère que je n'est pas était vague
l'exemple joint est mon but

 

[Patrice33740]

Re Salut Chris,
Bonjour le fil,

Avec des planches d'étiquettes c'est quand même bien plus facile qu'au massicot, surtout s'il y a des centaines d'étiquettes à imprimer.

En rectangulaire, il existe 70 x 16,9 mm qui est le plus proche (Avery 3420 ou Apli Agipa 118993) de 60 x 15 mm.. (Tu pourrais aussi définir tes propres planches et t'armer d'un massicot)

En utilisant un tableau structuré nommé "Produits" pour les données et une feuille "Liste étiquettes" pour les étiquettes :
- voici une macro qui crée automatiquement un document Word, résultat d'un publipostage de tes données sur une (des) planches d'étiquettes Avery 3420.
- Il n'y a plus qu'à lancer l'impression : il faut toujours éviter de le faire automatiquement par macro, il vaut mieux un petit clic qu'un grand clac !.

La Macro :

Option Explicit
Sub Etiquettes()
Dim tbl As ListObject
Dim rng As Range
Dim lig As ListRow
Dim nom As Name
Dim apW As Object
Dim doc As Object
Dim tmp As Object
Dim wrg As Object
Dim qte As Variant
Dim txt As String
Dim cnx As String
Dim nbL As Long
  Worksheets("Liste étiquettes").Cells.Clear
  For Each nom In ThisWorkbook.Names
    If nom.Name = "Etiquettes" Then nom.Delete
  Next nom
  Set tbl = Range("Produits").ListObject
  Set rng = Worksheets("Liste étiquettes").Range("A1")
  rng.Value = "Etiquettes"
  qte = Range("Produits[Qté]").Value
  For Each lig In tbl.ListRows
    For nbL = 1 To qte(lig.Index, 1)
      Set rng = rng.Offset(1)
      txt = lig.Range(1, 1).Value
      txt = txt & " -- " & lig.Range(1, 2).Value & " -- "
      txt = txt & "(" & nbL & "/" & lig.Range(1, 3).Value & ")"
      rng.Value = txt
    Next nbL
  Next lig
  Set rng = Worksheets("Liste étiquettes").Range("A1").CurrentRegion
  rng.EntireColumn.AutoFit
  ThisWorkbook.Names.Add "Etiquettes", rng, True
  Set apW = CreateObject("Word.Application")
  With apW
    .DisplayAlerts = True  'False
    .Visible = False
  End With
  Set tmp = apW.Documents.Add
  Set doc = apW.MailingLabel.CreateNewDocument(Name:="3420")
  tmp.Close False
  With doc
    Set wrg = .Content
    With wrg
      With .Tables(1).Range
        .Cells.VerticalAlignment = 1  ' wdCellAlignVerticalCenter
        .Paragraphs.Alignment = 1     ' wdAlignParagraphCenter
        .Font.Size = 18
        .Font.Bold = True
      End With
      .EndOf Unit:=6                  ' wdStory
      .EndOf Unit:=1, Extend:=1       ' wdCharacter , wdExtend
      .Font.Size = 2
      .StartOf Unit:=6                ' wdStory
    End With
    With .MailMerge
      .MainDocumentType = 1           ' wdMailingLabels
      .OpenDataSource Name:=ThisWorkbook.FullName, _
                      SQLStatement:="SELECT * FROM `Etiquettes`", _
                      SQLStatement1:="", SubType:=1                               ' wdMergeSubTypeAccess
    End With
    doc.Fields.Add Range:=apW.Selection.Range, Type:=59, Text:="""Etiquettes"""   ' Type:=wdFieldMergeField
    apW.WordBasic.MailMergePropagateLabel
    With .MailMerge
      .Destination = 0                ' wdSendToNewDocument
      .SuppressBlankLines = True
      With .DataSource
        .FirstRecord = 1              ' wdDefaultFirstRecord
        .LastRecord = -16             ' wdDefaultLastRecord
      End With
      .Execute Pause:=False
    End With
    .Close False
  End With
  With apW
    .Visible = True
    .WindowState = 1                  ' wdWindowStateMaximize
    .Activate
  End With
End Sub

Le fichier :

 

[chris]

RE

Pas sûr qu'en Algérie tous les format soient disponibles mais ce n'est pas moi qui ai proposé le massicot ou le cutter au départ...

Ici comme ailleurs, plus de nouvelles de chingilou qui a pris la solution de sylvanu...

 

[Patrice33740]

Ici comme ailleurs, plus de nouvelles de chingilou qui a pris la solution de sylvanu...

C'est pas important , ce n'est pas pour lui que j'ai reposté ici.
Ça peut servir à quelqu'un d'autre .

 

[Staple1600]

Bonsoir le fil

Ça peut servir à quelqu'un d'autre .

=>Patrick33740
Surtout pas à moi, malheureux!
Sinon, tout irait trop vite et je pourrais plus boire mon tit café avec la tite dame (cf message#5)


NB: Ceci je mets ton post dans mes signets parce qu'on ne sait jamais...
La petite dame pourrait être remplacer par un p'tit gars.

 

[chingilou]

bonsoir les exceleurs et merci encore de ces solutions suggérées
justement j'était en voyage pour livraison je viens à l'instant d'entrer
certes j'ai commencé a adapté la solution de sylvanu à mon fichier
mais dés demain matin je testerai l'autre soluce du publipostage
merci encore