Selected Answer
Hi Benjamin
I've modifed the code to allow for the extra column (its effect on the loop and source of document name) and added code to copy paste the QR code from column 16 (P) into Word bookmarks like qr_1 and qr_2 - these are in the revised tempate (embedded in the Excel workbook attached) which needs storing in the same folder as the workbook.
Only the For loop changes really and that's to loop through the shapes and see if they are "in" the cell. My understanding is that they are really in the drawing layer above the cells but we can use the Shapes.TopLeftCell property which returns the address of the cell where the top left corner is positioned above. I compare that with the address of cell in the loop (when iCol=16) and just copy/paste the shape (QR code) into Wiord if there's a match.
The key changes are in bold in the extract below:
For iCol = 1 To 16 'from column A to P...
TargBook = sh.Cells(1, iCol).Value & "_" & iRow - 1 'create target bookmark name
If WdDoc.Bookmarks.Exists(TargBook) = True Then 'check header bookmark exists then...
If iCol <> 16 Then ' for text columns...
wd.Selection.Goto what:=wdGoToBookmark, Name:=TargBook
wd.Selection.TypeText Text:=sh.Cells(iRow, iCol).Value 'take column value from loop row
WdDoc.Bookmarks(TargBook).Delete ' delete bookmark
Else 'where the QR codes or other images are stored
Dim Shp As Shape ' declare for shapes in worksheet
For Each Shp In sh.Shapes 'loop through shapes to see if they are over the cell
If sh.Cells(iRow, iCol).Address = Shp.TopLeftCell.Address Then
Shp.Copy ' if so copy it
wd.Selection.Goto what:=wdGoToBookmark, Name:=TargBook
wd.Selection.Paste ' and paste qr in bookmark
End If
Next Shp
WdDoc.Bookmarks(TargBook).Delete ' delete bookmark
End If
Else
n = MsgBox("Please check template; cannot find Word bookmark: " & TargBook, vbOKOnly) ' Tell user something's missing
Exit Do 'then stop populating Word document
End If
Next iCol
Again other users should note that the code relies on the
Microsoft Word 16.0 Object library (or other version) being installed already (via VB Editor/Tool/References).
I think this should work for you but this approach may be too slow when you have lots of rows (/labels).
If so, it may be necessary to collect all the shape/address data before the Do While loop is run (and not repeat the checks for each cell in column P). Out of interest only (for now), I've left new Module2 in the workbook- that collects the names of shapes and the "top left cell" addresses into a 2-D array (and prints them into the Intermediate pane of the VB Editor):
Sub GetShpAddr()
' populate an array with the cell addresses for shapes in sheet
Dim Shp As Shape, ShpTot As Long
Dim ShpAddrs() As Variant
ShpTot = ActiveSheet.Shapes.Count
ReDim ShpAddrs(1 To ShpTot, 1 To 2)
i = 1
For Each Shp In ActiveSheet.Shapes
ShpAddrs(i, 1) = Shp.TopLeftCell.Address
ShpAddrs(i, 2) = Shp.Name
Debug.Print ShpAddrs(i, 1) & ": " & ShpAddrs(i, 2)
i = i + 1
Next Shp
End Sub
Hope this helps.