Hi Alex,
Wer wird denn gleich so schnell aufgeben? Dass es sich bei den Bildern um QR-Codes handelt ist eine wichtige Info die du uns mal eben einfach verschwiegen hast. Das macht die Sache natürlich viel einfacher. Und natürlich kannst du das Ganze auch nebeneinander darstellen. Probier mal den folgenden Code in Word und berichte. Den Pfad musst du natürlich genauso anpassen, wie den Taebellennamen des Excel-Blattes im SQL-Statement.
Außerdem kann es sein, dass deine Felder nicht "Datei" und "Name" sondern anders heißen. In dem Fall auch die Feldnamen im Code anpassen.
Sub Etikett_Erstellen()
Dim doc As Document, cl As Cell, i As Long
Set doc = Application.MailingLabel.CreateNewDocumentByID(LabelId:="805957182")
doc.MailMerge.OpenDataSource Name:="D:\Pfad\SerienNames.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:="Datei"
doc.MailMerge.Fields.Add Range:=.Cell(1, 2).Range, Name:="Datei"
EndRange(.Cell(1, 2).Range).InsertAfter vbNewLine
doc.MailMerge.Fields.Add Range:=EndRange(.Cell(1, 2).Range), Name:="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
'Stop
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
'Stop
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
Gruß Mr. K.
|