Too high complexity for a find and replace between Excel and Word docs

Question

Here's my current objective:

• I have an Excel document which contains n rows with 2 columns (C1 and C2) of data
• I have a Word document containing n tables with 1st row (R1) containing C2

I want to add in my Word doc the content of C1 inside my tables based on R1==C2.

I have a working project to do that, but you can clearly see that the complexity is N², and for a large amount of data it becomes impossible to finish...

Here's what I have so far:

Set WA = CreateObject("Word.Application")
WA.Documents.Open (pathh)
WA.Visible = True
   
For j = 1 To WA.ActiveDocument.Tables.Count
 For i = 2 To N
     With WA.ActiveDocument.Tables(j).Range.Find
        .ClearAllFuzzyOptions
        .ClearHitHighlight
        .ClearFormatting
        .Text = Cells(i, 2)
        .Forward = False
        .Wrap = wdFindStop

        If .Execute Then
            WA.ActiveDocument.Tables(j).Rows(3).Cells(1).Range.Text = Cells(i, 1)
            Exit For
        End If
    End With
 Next
Next

Any help would be really appreciated, thanks!

Answer 1

Assuming the first cell in each table contains only the value that you want to use to identify the table.

Sub UpdateWordTables()
    Const PATHH = "C:\Users\Owner\Documents\Doc1.docx"
    Dim j As Integer, x As Long
    Dim key As String
    Dim r As Range, tbl As Object, WA As Object
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")
        For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
            dict(r.Offset(0, 1).Text) = r.Text
        Next
    End With

    Set WA = CreateObject("Word.Application")
    WA.Documents.Open (PATHH)
    WA.Visible = True

    For Each tbl In WA.ActiveDocument.Tables

        With tbl
            key = .cell(1, 1).Range.Text
            'Trim Word Cell delimiters from text
            key = Left(key, Len(key) - 2)

            If dict.Exists(key) Then
                .cell(3, 1).Range.Text = dict(key)
            End If
        End With
    Next

    Set WA = Nothing
End Sub