Excel 到 Word VBA - 每 x 行导出带有徽标的数据

Question

我正在尝试创建一组 plates（一组 5 行，其中一些数据取自主工作表）并创建一个 Word 文件，每页放置 2 个板。在每个盘子之前我想插入一个标志（我试图在 for 循环中添加标志，但我现在迷路了），具有自定义样式（与结果页面相同） 到目前为止，我有部分代码，我向您展示了我试图获得的结果： （第一张是最终结果，第二张是我现在得到的结果）

Option Explicit

Sub PrintLabels_Word()

Dim wb As Workbook, ws As Worksheet, wsPDF As Worksheet, xWs As Worksheet, WdObj As Object
Dim iLastRow As Long, ar(1 To 7, 1 To 1), rng As Range
Dim i As Long, r As Long, c As Integer, k As Integer
Dim LastRow As Long
Dim area As Range
Dim saveLocation As String
Dim strFileName As String, myRow As Long

  
Set wb = ThisWorkbook
Set ws = wb.Sheets("Summary")
Set wsPDF = wb.Sheets("Foglio1")
Set xWs = Application.ActiveSheet
wsPDF.Cells.Clear
xWs.ResetAllPageBreaks


' fixed
ar(1, 1) = ws.Cells(1, 10)
ar(2, 1) = "CLIENT: " & ws.Cells(1, 7)
ar(3, 1) = "ORDER" & " " & ws.Cells(2, 7)
ar(5, 1) = "JOB" & " " & ws.Cells(1, 2) & " " & ws.Cells(1, 3)
ar(6, 1) = "CASE NUMBER: 1/1"

iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
r = 1 ' start row
c = 1 ' column A
For i = 6 To iLastRow
    ar(4, 1) = "INSIDE CASE (TAG):  " & ws.Cells(i, "H")
    
   
    ' fill plate
    Set rng = wsPDF.Cells(r, c).Resize(7, 1)
    rng.Value2 = ar
   
    ' merge cells
    For k = 1 To 7
        With rng.Cells(k, 1).Resize(1, 4)
            .Merge
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
        End With
    Next
    
    r = r + 8
            
Next

MsgBox "Done"
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.Zoom = 200
.FitToPagesTall = False
.FitToPagesWide = False

End With

Dim tblRange As Excel.Range
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordTable As Word.Table

iLastRow = wsPDF.Cells(Rows.Count, 1).End(xlUp).Row
Set tblRange = ThisWorkbook.Worksheets("Foglio1").Range("A1:D" & iLastRow)

On Error Resume Next
Set WordApp = GetObject(class:="Word.Application")
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")

'WordApp.Visible = True
'WordApp.Activate

Set WordDoc = WordApp.Documents.Add

tblRange.Copy
WordDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False


With WordApp
.ChangeFileOpenDirectory ThisWorkbook.Path
.ActiveDocument.SaveAs Filename:="Targhetta Adesiva" & " " & ws.Range("B3").Value & "_" & 
ws.Range("G1").Value & ".doc"
.ActiveDocument.Close
End With
End Sub

Answer 1

您正在尝试重新发明轮子。 Word 已经具备您需要的所有功能。它被称为邮件合并（或邮件），它可以使用 Excel 中的数据。

要在一页上获得多个印版，请从标签合并设置开始，然后自定义布局表以满足您的需求。

要与图像进行邮件合并，请将所有图像存储到一个文件夹中，将唯一的图像 ID 和每个图像路径作为两个单独的数据列放入 Excel 源中。然后将该信息插入图像合并字段。

更多详情见https://community.spiceworks.com/how_to/2675-using-mailmerge-to-insert-images

所有这些都可以在不编写一行 VBA 的情况下完成。