使用VBA将MS WORD中的非线性表格与Excel表格进行邮件合并

Question

我想将包含 Microsoft Word 中的非线性表的 Word 文档与 Excel 表格进行邮件合并。 Word 和 Excel 文档包含带有 3 个邮件合并参数的表，名为“Exigence”、“NC”和“Commentaire”Excel 表中的每个条目必须为结果提供同一 Word 文档中的一个新表，其中包含来自 Excel 表和跨越线的值在每个表之间，因此代码必须允许用户在 Word 表中定位条目，因为“NC”和“Exigences”将邮件合并到 Word 文档中的同一单元格中。该代码还必须让用户通过对话框选择 Excel 文件位置。我还指出，参数“Commentaire”具有很长的文本，可以在一页中打印，因此当您选择此变量的类型时请注意这一点。 这段代码的问题在于，结果是一个带有重复表的 Word 文档，每个值都没有 Excel 表中的值，请有人帮助我。

我制作的代码：

Sub MailMergeFromExcel()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet
Dim dlgOpen As FileDialog
Dim xlFilePath As String
Dim i As Integer
Dim tbl As Word.Table
Dim rng As Word.Range
Dim newTable As Word.Table
Dim cell As Word.Cell
Dim cellText As String

' Initialize Word Application
Set wdApp = Application
Set wdDoc = wdApp.ActiveDocument

' Initialize Excel Application
Set xlApp = New Excel.Application

' Open file dialog to select Excel file
Set dlgOpen = xlApp.FileDialog(msoFileDialogOpen)

dlgOpen.Title = "Select the Excel File"
dlgOpen.Filters.Add "Excel Files", "*.xls; *.xlsx", 1

If dlgOpen.Show <> -1 Then Exit Sub ' User canceled

xlFilePath = dlgOpen.SelectedItems(1)

' Open the selected Excel file
Set xlWb = xlApp.Workbooks.Open(xlFilePath)
Set xlWs = xlWb.Sheets(1)

' Loop through each row in the Excel table
For i = 2 To xlWs.UsedRange.Rows.Count ' Assuming first row is headers

' Find the template table
Set tbl = wdDoc.Tables(1) ' Assumes the template table is the first table in the document

' Copy the template table
tbl.Range.Copy

' Insert a new table based on the template
Set rng = wdDoc.Range
rng.Collapse wdCollapseEnd
rng.InsertParagraphAfter
rng.Collapse wdCollapseEnd
rng.Paste
Set newTable = wdDoc.Tables(wdDoc.Tables.Count)

' Replace placeholders with Excel data
For Each cell In newTable.Range.Cells

cellText = cell.Range.Text
cellText = Replace(cellText, Chr(13) & Chr(7), "") ' Remove end of cell marker

Select Case cellText
Case "{Exigence}"
cell.Range.Text = xlWs.Cells(i, 1).Value ' Assuming "Exigence" is in column A
Case "{NC}"
cell.Range.Text = xlWs.Cells(i, 2).Value ' Assuming "NC" is in column B
Case "{Commentaire}"
cell.Range.Text = xlWs.Cells(i, 3).Value ' Assuming "Commentaire" is in column C
Case Else
Debug.Print "Placeholder not found: " & cellText
End Select
Next cell

' Add a line break after the table
newTable.Range.InsertParagraphAfter
newTable.Range.Paragraphs.Last.Range.InsertParagraphAfter

Next i

' Cleanup
xlWb.Close False
xlApp.Quit
Set xlWs = Nothing
Set xlWb = Nothing
Set xlApp = Nothing
End Sub

Excel表格示例

词表示例

Answer 1

这里有一些使用

Find

的不同方法的示例代码来定位任何给定范围中的所有占位符标签 (

{sometexthere}

) 并返回一个范围集合，然后您可以对其进行处理。

Sub Tester()
    
    Dim col As Collection, el
    
    Set col = GetTags(ThisDocument.Tables(2).Range)
    For Each el In col        'loop over returned ranges
        Select Case el.Text
            Case "{A}": el.Text = "this was A"
            Case "{B}": el.Text = "this was B"
            Case "{C}": el.Text = "this was C"
        End Select
    Next el
    
End Sub


'return a collection of all ranges like `{*}`
'   within range `rng`
Function GetTags(rng As Word.Range) As Collection
    Set GetTags = New Collection
    With rng.Find
        .ClearFormatting
        .Text = "\{*\}"
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        Do While .Execute
            GetTags.Add rng.Duplicate 'save this range...
        Loop
    End With
End Function