Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 14 Aug 2021
Dim oSource As Document, oTarget As Document
Dim oTable1 As Table, oTable2 As Table
Dim oRng1 As Range, oRng2 As Range
Dim i As Long
    Set oTarget = Documents.Add("C:\Path\Doc A.docx")
    Set oSource = Documents.Open("C:\Path\Doc B.docx")
    Set oTable1 = oSource.Tables(1)
    Set oTable2 = oTarget.Tables(1)
    For i = 4 To oTable1.Rows.Count
        Set oRng1 = oTable1.Cell(i, 3).Range
        oRng1.End = oRng1.End - 1
        Set oRng2 = oTable2.Cell(i, 3).Range
        oRng2.End = oRng2.End - 1
        oRng2.FormattedText = oRng1.FormattedText
        If oRng2.Text = "" Then
            oRng2.Text = "###"
            oRng2.Font.Name = "Times New Roman"
            oRng2.Font.Size = 22
        End If
    Next i
lbl_exit:
    oSource.Close 0
    Set oTarget = Nothing
    Set oSource = Nothing
    Set oTable1 = Nothing
    Set oTable2 = Nothing
    Set oRng1 = Nothing
    Set oRng2 = Nothing
    Exit Sub
End Sub

Option Explicit

Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 15 Aug 2021
Dim oSource As Document, oTarget As Document
Dim oTable1 As Table, oTable2 As Table
Dim oRng1 As Range, oRng2 As Range
Dim i As Long
Dim sName As String, sSource As String
    On Error GoTo lbl_Exit
    sName = BrowseForFile("Select Target document")
    If sName = "" Then
        MsgBox "User cancelled"
        GoTo lbl_Exit
    End If
    Set oTarget = Documents.Add(sName)

    sSource = BrowseForFile("Select Source document")
    If sSource = "" Then
        MsgBox "User cancelled"
        oTarget.Close 0
        GoTo lbl_Exit
    End If
    Set oSource = Documents.Open(sSource)

    If oSource.Tables.Count > 0 Then
        Set oTable1 = oSource.Tables(1)
    Else
        MsgBox "Document has no table", vbCritical
        GoTo lbl_Exit
    End If
    If oTarget.Tables.Count > 0 Then
        Set oTable2 = oTarget.Tables(1)
    Else
        MsgBox "Document has no table", vbCritical
        GoTo lbl_Exit
    End If
    If Not oTable1.Rows.Count = oTable2.Rows.Count Then GoTo lbl_Exit
    For i = 4 To oTable1.Rows.Count
        Set oRng1 = oTable1.Cell(i, 3).Range
        oRng1.End = oRng1.End - 1
        Set oRng2 = oTable2.Cell(i, 3).Range
        oRng2.End = oRng2.End - 1
        oRng2.FormattedText = oRng1.FormattedText
        If oRng2.Text = "" Then
            oRng2.Text = "###"
            oRng2.Font.Name = "Times New Roman"
            oRng2.Font.Size = 22
        End If
    Next i
    sName = Left(sName, InStrRev(sName, Chr(46)) - 1) & "_Reviewed.docx"
    oTarget.SaveAs2 sName
lbl_Exit:
    If Not oSource Is Nothing Then oSource.Close 0
    Set oTarget = Nothing
    Set oSource = Nothing
    Set oTable1 = Nothing
    Set oTable2 = Nothing
    Set oRng1 = Nothing
    Set oRng2 = Nothing
    Exit Sub
End Sub

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
'Graham Mayor
'strTitle is the title of the dialog box
'Set bExcel value to True to filter the dialog to show Excel files
'The default is to show Word files
Dim fDialog As FileDialog
    On Error GoTo err_Handler
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo err_Handler:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
err_Handler:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

If Not oTable1.Rows.Count = oTable2.Rows.Count Then GoTo lbl_Exit

If Not oTable1.Rows.Count = oTable2.Rows.Count Then
    MsgBox "The tables do not have the same number of rows", vbCritical
    GoTo lbl_Exit
End If

Set oSource = Documents.Open(sSource)

 oSource.AcceptAllRevisions