Transfer Data from large Excel file to multiple tables in word document

Question

I am trying to transfer data from a large excel sheet into small tables in a word document. I want to do this by matching the first column in a row and then copying the cells in the in the columns to the right in the row.

For example, here is the table in the excel file:

Company	First Name	Last Name
Apple	Tom	Tommy
Google	Ann	Anny
Amazon	Driver	Ted

In the word documents there are multiple tables. I want to populate the names that match with the company. Right now the tables look like this:

Company	First Name	Last Name
Google
Amazon

Company	First Name	Last Name
Google
Apple

Company	First Name	Last Name
Google
Amazon
Apple

I want the names to be added so they would look like this:

Company	First Name	Last Name
Google	Ann	Anny
Amazon	Driver	Ted

Company	First Name	Last Name
Google	Ann	Anny
Apple	Tom	Tommy

Company	First Name	Last Name
Google	Ann	Anny
Amazon	Driver	Ted
Apple	Tom	Tommy

I am open to any option that would help me do this. I was trying Mail Merge but it seems to be to labor intensive and not save time. Thanks for the help.

Answer 1

For the first approach you can use this code in MS Word, where you want to fill tables. The code is not optimized and error check is omitted. It expects the named range 'MyData' exists and contains exactly three columns [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