Sub Etikett_Erstellen()
Dim doc As Document, cl As Cell, i As Long
Set doc = Application.MailingLabel.CreateNewDocumentByID(LabelId:="805957182")
doc.MailMerge.OpenDataSource Name:="C:\Test\Dateiname.xlsx", SQLStatement:="SELECT * FROM `Tabelle1$`"
ActiveWindow.View.ShowFieldCodes = True
For Z = 1 To 8
For s = 1 To 5 Step 2
Set cl = doc.Tables(1).Cell(Z, s)
With cl.Tables.Add(Range:=cl.Range, NumRows:=1, NumColumns:=2)
For i = 1 To 8
.Borders(-i).LineStyle = wdLineStyleNone
Next i
.TopPadding = CentimetersToPoints(0)
.BottomPadding = CentimetersToPoints(0)
.LeftPadding = CentimetersToPoints(0)
.RightPadding = CentimetersToPoints(0)
.Spacing = 0
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = cl.Height
doc.Fields.Add Range:=StartRange(.Cell(1, 1).Range), Text:="DISPLAYBARCODE ""Hier"" QR"
doc.MailMerge.Fields.Add Range:=PartRange(.Cell(1, 1).Range, "Hier"), Name:="Token"
doc.MailMerge.Fields.Add Range:=.Cell(1, 2).Range, Name:="Username"
EndRange(.Cell(1, 2).Range).InsertAfter vbNewLine
doc.MailMerge.Fields.Add Range:=EndRange(.Cell(1, 2).Range), Name:="Voller Name"
.Cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(1, 1).VerticalAlignment = wdCellAlignVerticalCenter
.Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(1, 2).VerticalAlignment = wdCellAlignVerticalCenter
If Not (Z = 1 And s = 1) Then doc.Fields.Add Range:=StartRange(.Cell(1, 1).Range), Text:="NEXT "
End With
Next s
Next Z
ActiveDocument.MailMerge.Destination = wdSendToNewDocument
ActiveDocument.MailMerge.Execute Pause:=False
ActiveWindow.View.ShowFieldCodes = False
End Sub
Function EndRange(rng As Range) As Range
Dim myRange As Range
Set myRange = rng
myRange.SetRange rng.End - 1, rng.End - 1
Set EndRange = myRange
End Function
Function StartRange(rng As Range) As Range
Dim myRange As Range
Set myRange = rng
myRange.SetRange rng.Start, rng.Start
Set StartRange = myRange
End Function
Function PartRange(rng As Range, LookFor As String) As Range
Dim myRange As Range, s As Long, e As Long
Set myRange = rng
s = InStr(myRange, LookFor)
e = s + Len(LookFor)
myRange.SetRange rng.Start + s - 1, rng.Start + e - 1
Set PartRange = myRange
End Function