VBA copy issues

[syl3786]

Hi everyone,



Previously, I worked on a project where I need to copy specific text from a Word document into an Excel workbook according to an Excel file. I've written some VBA code to do this, but I'm running into some issues.

Here is the code I'm using:

Option Explicit

Sub CopyText_from_Word_to_Excel()

On Error Resume Next
    ' Declare variables
    Dim xlWB1 As String
    Dim xlWB2 As String
    Dim xlSheet As String
    Dim EXL As Object
    Dim oDoc As Document
    Dim oRng As Range
    Dim Arr() As Variant
    
    ' Set the path to the Excel workbook to copy data from
    xlWB1 = "C:\Users\Excel file\list.xlsx"
    
    ' Show a file dialog box to select the Excel workbook to copy data to
    xlWB2 = BrowseForFile("Select Workbook", True)
    If xlWB2 = vbNullString Then Exit Sub
    
    ' Set the name of the worksheet to copy data to
    xlSheet = "Sheet1"
    
    ' Create an instance of Excel and open the target workbook
    Set EXL = CreateObject("Excel.Application")
    EXL.Visible = True
    EXL.Workbooks.Open xlWB2
    
    ' Get a reference to the active Word document and search for each value in the Excel workbook
    Set oDoc = ActiveDocument
    Set oRng = oDoc.Range
    Arr = xlFillArray(xlWB1, xlSheet)
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Name = "Times New Roman"
        .Font.Bold = True
        Dim ind As Long
        For ind = LBound(Arr, 2) To UBound(Arr, 2)
            .Text = Arr(1, ind)
            Do While .Execute()
                WriteToWorksheet xlWB2, xlSheet, oRng.Text
            Loop
        Next ind
    End With
End Sub

Public Function WriteToWorksheet(strWorkbook As String, _
                                  strRange As String, _
                                  strValues As String)
    ' Declare variables
    Dim ConnectionString As String
    Dim strSQL As String
    Dim CN As Object
    
    ' Set the connection string and SQL statement to write data to the worksheet
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkbook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    
    ' Open a connection to the workbook and execute the SQL statement
    Set CN = CreateObject("ADODB.Connection")
    CN.Open ConnectionString
    CN.Execute strSQL
    CN.Close
End Function

Public Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
    ' Declare variables
    Dim fDialog As FileDialog
    
    ' Show a file dialog box to select a file
    On Error Resume Next
    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
            BrowseForFile = fDialog.SelectedItems.Item(1)
        End If
    End With
End Function

Public Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
    ' Declare variables
    Dim RS As Object
    Dim CN As Object
    Dim iRows As Long
    
    ' Set the connection string and SQL statement to read data from the worksheet
    strRange = strRange & "$]"
    Set CN = CreateObject("ADODB.Connection")
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1
    
    ' Get the data from the recordset and close the connection and recordset
    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    RS.Close
    CN.Close
End Function

The issue I'm having is that the text is not getting copied from Word to Excel according to the xlWB1 workbook. I believe the problem may be with the RS.Open "SELECT * FROM [" & strRange, CN, 2, 1 line, but I'm not sure how to fix it.

Can anyone offer any suggestions on how to fix the issue with my code and get it working as expected?

Thank you in advance for your help!

Word document for testing: Loading Google Docs

Excel template: Loading Google Sheets

Excel list: Loading Google Sheets

Excel file (Expected outcome): Loading Google Sheets