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