Copy tables from documents to another documents with predefined bookmarks

[Pearce]

Today I came across a post by gmayor in the topic "Read Excel Cell from Word VBA" in this forum.

I have used the xlFillArray function to read a worksheet into array. In the worksheet "SourceTarget" in the column A there are listed the source documents (e.g. C:\Source\001_01_Source_VK.docx) and in the column B there are listed the target documents (e.g. C:\Target\001_01_Target_VK.docx).

Option Explicit
Private Const strWorkbook As String = "C:\CopyTables\MatchingTables.xlsx" 'The path of the workbook
Private Const strSheet As String = "SourceTarget" 'The name of the worksheet

Sub CopyTablesFromDocs2Docs()
    Dim oSourceDoc As Document
    Dim oTargetDoc As Document
    Dim oRng As Word.Range
    Dim excelArray() As Variant
    Dim excelArrayLen As Integer
    Dim i As Integer
    'Optimize Code
    Application.ScreenUpdating = False
    excelArray = xlFillArray(strWorkbook, strSheet)
    excelArrayLen = UBound(excelArray, 2) - LBound(excelArray, 2) + 1
    For i = 1 To excelArrayLen
         Set oSourceDoc = Documents.Open(excelArray(0, i - 1))
         Set oTargetDoc = Documents.Open(excelArray(1, i - 1))
         With oTargetDoc
             Set oRng = .Bookmarks("BookmarkA").Range
             oRng.FormattedText = oSourceDoc.Tables(1).Range.FormattedText
             .Bookmarks.Add "BookmarkA", oRng
             Set oRng = .Bookmarks("BookmarkB").Range
             oRng.FormattedText = oSourceDoc.Tables(2).Range.FormattedText
             .Bookmarks.Add "BookmarkB", oRng
         End With
         Set oRng = Nothing
         oSourceDoc.Close
         oTargetDoc.Save
         oTargetDoc.Close
    Next
End Sub

Private Function xlFillArray(strWorkbook As String, strRange As String) As Variant
    'Graham Mayor - 24/09/2016
    Dim RS As Object
    Dim CN As Object
    Dim iRows As Long
    strRange = strRange & "$]"    'Use this to work with a named worksheet
    'strRange = strRange & "]" 'Use this to work with a named range
    Set CN = CreateObject("ADODB.Connection")
    'Set HDR=YES for a sheet or range with a header row
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & strWorkbook & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1
    With RS
          .MoveLast
          iRows = .RecordCount
          .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
    lbl_Exit:
    Exit Function
End Function

I will try to work out the selection of tables from the source documents by their title. I will be glad for any comment/help/advice. Thanks