将数据从大型 Excel 文件传输到 Word 文档中的多个表

Question

我正在尝试将大型 excel 工作表中的数据传输到 Word 文档中的小表格中。 我想通过匹配一行中的第一列然后将列中的单元格复制到行的右侧来做到这一点。

例如，下面是 excel 文件中的表：

公司	名	姓
苹果	汤姆	汤米
谷歌	安	安妮
亚马逊	司机	泰德

在word文档中有多个表。 我想填充与公司匹配的名称。 现在表格看起来像这样：

公司	名	姓
谷歌
亚马逊

公司	名	姓
谷歌
苹果

公司	名	姓
谷歌
亚马逊
苹果

我希望添加名称，以便它们看起来像这样：

公司	名	姓
谷歌	安	安妮
亚马逊	司机	泰德

公司	名	姓
谷歌	安	安妮
苹果	汤姆	汤米

公司	名	姓
谷歌	安	安妮
亚马逊	司机	泰德
苹果	汤姆	汤米

我愿意接受任何可以帮助我做到这一点的选择。 我正在尝试邮件合并，但它似乎是劳动密集型的，而不是节省时间。 谢谢您的帮助。

Answer 1

对于第一种方法，您可以在要填写表格的 MS Word 中使用此代码。 代码未优化，省略了错误检查。 它期望命名范围“MyData”存在并且恰好包含三列 [company, name1, name2]

'Add reference to the 'Microsoft Excel 16.0 Object Library' is required

Sub FillTablesFromExcel()
    
    Dim doc As Word.Document
    Set doc = ThisDocument
    
    Dim data
    data = ReadDataFromExcel
    
    Dim t As Word.Table
    For Each t In doc.Tables
        If t.Columns.Count <> 3 Then Exit For
        
        Dim r As Word.Row
        For Each r In t.Rows
            Dim txt As String
            txt = r.Cells(1).Range.Text
            company = Trim(Left(txt, Len(txt) - 2))
            
            For i = 1 To UBound(data)
                comp = data(i, 1)
                name1 = data(i, 2)
                name2 = data(i, 3)
                
                If company = comp Then
                    r.Cells(2).Range.Text = name1
                    r.Cells(3).Range.Text = name2
                End If
            Next
        Next
    Next

End Sub

Function ReadDataFromExcel()

    Dim xlsWorkbook As Excel.Workbook
    Set xlsWorkbook = Excel.Workbooks.Open("C:\Path\To\The\File.xlsx", ReadOnly:=True)
    
    Dim xlsSheet As Excel.Worksheet
    Set xlsSheet = xlsWorkbook.Sheets(1)
    
    Dim dataRange As Excel.Range
    Set dataRange = xlsSheet.Range("MyData")
    
    Value2 = dataRange.Value2
    
    Call xlsWorkbook.Close(False)
    ReadDataFromExcel = Value2
End Function