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:
Code:
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