Adding more barcodes to a 4x6 label in VBA-CodePudding

I am trying to make a 4x6 label with 7 code-39 barcodes on it, but it seems like my VBA code is overwriting each barcode. The data is pulled from an excel file in cells B2 - B8, right now I am stuck on just getting 2 to print. It just prints the data from B3 instead of B2 and B3 at this time.

I'd also like to figure out how to get text to show up above each barcode from columns A2 - A8, but haven't even gotten to this step yet. I've tried looking up how to do this but haven't found much information on VBA to word apps. Below is my code, I would really appreciate any help as I don't have any experience with VBA.

Sub Button2_Click()
Dim WdApp As Object, WdDoc As Object, StrCd As String, StrCl As String
With ActiveSheet
  StrCd = Chr(34) & .Range("B2").Value & Chr(34)
  StrCl = Chr(34) & .Range("B3").Value & Chr(34)
  
End With
Set WdApp = CreateObject("Word.Application"): Set WdDoc = WdApp.Documents.Add
With WdDoc
  .PageSetup.PageWidth = 288: .PageSetup.PageHeight = 432: .PageSetup.RightMargin = 36: .PageSetup.LeftMargin = 36
  .Fields.Add .Range, -1, "DISPLAYBARCODE " & StrCd & " CODE39 \d \t", False
  .Fields.Add .Range, -1, "DISPLAYBARCODE " & StrCl & " CODE39 \d \t", False
  With .Range
    With .ParagraphFormat
      .LineSpacingRule = 0 'wdLineSpaceSingle
      .SpaceBefore = 0
      .SpaceAfter = 1
    End With
    
    .Copy
  End With
  ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
  .Close False
End With
Set WdDoc = Nothing: WdApp.Quit: Set WdApp = Nothing
End Sub

CodePudding user response：

You can try something like this:

Option Explicit

Sub Button2_Click()
    Const PER_ROW As Long = 3 '# of labels per row in layout
    Dim WdApp As Object, WdDoc As Object, StrCd As String, StrCl As String
    Dim c As Range, wsData As Worksheet, wsLabel As Worksheet, v, i As Long
    
    'set up a Word doc for generating the barcodes
    Set WdApp = CreateObject("Word.Application")
    WdApp.Visible = True
    Set WdDoc = WdApp.Documents.Add
    With WdDoc.PageSetup
        .PageWidth = 288
        .PageHeight = 432
        .RightMargin = 36
        .LeftMargin = 36
    End With
    
    Set wsData = ThisWorkbook.Worksheets("Label Data") 'data for labels on this sheet
    Set wsLabel = ThisWorkbook.Worksheets("Label")     'labels created on this sheet
    
    For Each c In wsData.Range("B2:B9").Cells
        v = Trim(c.Value)
        If Len(v) > 0 Then
            i = i   1
            With WdDoc.Fields.Add(WdDoc.Range, -1, "DISPLAYBARCODE " & v & _
                                   " CODE39 \d \t", False)
                .Copy
                If Not PasteWithRetry(wsLabel) Then 'make sure the paste succeeds
                    MsgBox "Paste failed!"
                    Exit For
                End If
                .Delete
            End With
            With wsLabel.Shapes(wsLabel.Shapes.Count) 'get the pasted shape
                .Top = Fix((i - 1) / PER_ROW) * 100    '...and position it
                .Left = ((i - 1) Mod PER_ROW) * 220
            End With
        End If
   Next c
    
   WdDoc.Close False
   WdApp.Quit
End Sub

'Pasting pictures in a loop is often unreliable, so
'  this tries multiple times before giving up...
'Returns True if paste was successful
Function PasteWithRetry(ws As Worksheet) As Boolean
    Dim n As Long, pasted As Boolean
    For n = 1 To 10               'try 10 times to paste
        On Error Resume Next      'ignore any paste error
        ws.PasteSpecial Format:="Picture (Enhanced Metafile)", _
                                Link:=False, DisplayAsIcon:=False
        pasted = (Err.Number = 0) 'no error = pasted OK
        On Error GoTo 0           'stop ignoring errors
        If pasted Then
            PasteWithRetry = True
            Exit Function   'exit if pasted OK
        End If
        DoEvents
    Next n
End Function

Output: