0

I have a Word document that contains some specific text that I need to copy and paste onto a selected Excel sheet according to an Excel file. Can anyone suggest a way to achieve this using VBA?

Here's what I have so far:

Option Explicit

Private xlWB1 As String
Private xlWB2 As String
Private xlSheet As String

Sub CopyText_from_Word_to_Excel()

Dim EXL As Object
Dim xlsWB1 As String
Dim xlsWB2 As Object
Dim xlsPath As String
Dim oDoc As Document
Dim oRng As Range
Dim Arr() As Variant

xlsWB1 = "D:\databases\ENG.xlsx"

xlsWB2 = BrowseForFile("Select Workbook", True)
If Not xlsWB2 = vbNullString Then

xlSheet = "sheet1"

    Set EXL = CreateObject("Excel.Application")
    Set oDoc = ActiveDocument
    Set oRng = oDoc.Range
    Arr = xlFillArray(xlsWB1, xlSheet)
   
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Name = "Times New Roman"
        .Font.Bold = True
        Dim ind As Long
        For ind = LBound(Arr) To UBound(Arr)
            .Text = Arr(ind)
            Do While .Execute()
                WriteToWorksheet xlsWB1, xlSheet, oRng.Text
            Loop
        Next ind
    End With
   
lbl_Exit:
    Exit Sub
    End If
   
            Set xlsWB2 = EXL.Workbooks.Open(xlsWB2)
    EXL.Visible = True
   
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
                                  strRange As String, _
                                  strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkbook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    Set CN = CreateObject("ADODB.Connection")
    Call CN.Open(ConnectionString)
    Call CN.Execute(strSQL, , 1 Or 128)
    CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function
Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
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
Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant

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=NO for no header row
    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

    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 tried the above code but it doesn't work. Those three private functions are workable in other VBA codes. I don't know how to write the code so as to copy specific text from a Word document and paste on selected Excel sheet according to an Excel file.

How can I achieve this?

The error occurred:https://drive.google.com/file/d/1eueMnOIaBuKlLUq2WSa298qOCklPkSbV/view?usp=share_link

The sample word file for testing:https://docs.google.com/document/d/1c68y2uu0BgUIjITIOpC7h8UpAv68rCpc/edit?usp=share_link&ouid=102729134456357219586&rtpof=true&sd=true

The expected outcome file: https://docs.google.com/spreadsheets/d/1-bGM88Tl4Ibou3bnK5QJHO8lo_0Vg53D/edit?usp=share_link&ouid=102729134456357219586&rtpof=true&sd=true

Thanks in advance for your help!

11
  • what specific text are you trying to copy from word? Commented Apr 30, 2023 at 12:07
  • @k1dr0ck a list of names ( more than 100 names in total, and in different languages, that's why the VBA need to in accordance with an Excel file. That Excel file contains those names) Commented Apr 30, 2023 at 12:20
  • When asking for help debugging code, it is expected that you include 1) the error you get 2) what line in your code causes the error 3) the values of relavent variables when the error occurs 4) a small sample data set as text in the question 5) expected results. Commented Apr 30, 2023 at 19:49
  • @chrisneilsen 1) The Error I get: Object variable not set (Error 91) 2) what line in the code causes the error: xlsWB1 = "D:\databases\ENG.xlsx" 3) the values of relevant variables when the error occurs : xlsWB1 = "D:\databases\ENG.xlsx" 4) a small sample data set as text in the question: docs.google.com/document/d/1c68y2uu0BgUIjITIOpC7h8UpAv68rCpc/… 5) expected results: docs.google.com/spreadsheets/d/… Commented May 1, 2023 at 1:20
  • That error is because you've Dim'd xlsWB1 as an object and treated it like a string. You probably want Set xlsWB1 = EXL.Open("D:\databases\ENG.xlsx") Commented May 1, 2023 at 2:55

1 Answer 1

0

The issue is not with the private functions. Your problem is that If oRng.Text = Arr will never evaluate to True. You need to loop through the array of names and set Find.Text to the current element, e.g.

    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Name = "Times New Roman"
        .Font.Bold = True
        Dim ind As Long
        For ind = LBound(Arr) To UBound(Arr)
            .Text = Arr(ind)
            Do While .Execute()
                WriteToWorksheet xlWB1, xlSheet, oRng.Text
            Loop
        Next ind
    End With
Sign up to request clarification or add additional context in comments.

3 Comments

Thank you for your reply. I tried but it doesn't work and keep shows error. May I ask if there is anything wrong? I edited the code by replacing your code in my original post since the comment box here doesn't allow to paste code.
@Christy8732 - On which line do you get the error?
1) The Error I get: Object variable not set (Error 91) 2) what line in the code causes the error: xlsWB1 = "D:\databases\ENG.xlsx" I also put the error printscreen, sample file for testing and the expected outcome on the original post.

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.