Need help with VBA macro to copy text from Word to Excel according to a list

syl3786 · #1 07-26-2023, 08:24 AM

Hello everyone,

I'm looking for help with a VBA macro that can automatically copy text from a Word document and paste it into Excel, according to a list of names.

Here's what I'm currently using:

1. Highlight text in Word document according to a list of names.

Code:

Sub Highlight_Words_From_Excel_NamedRange()

Const strWorkbook As String = "E:\Database\wordlist.xlsx"
Const strRange As String = "WordList"
Dim arr() As Variant
Dim lngRows As Long
Dim oRng As Range
Dim strFind As String
    arr = xlFillArray(strWorkbook, strRange)
    For lngRows = 0 To UBound(arr, 2)
        strFind = arr(0, lngRows)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            Do While .Execute(findText:=strFind)
                oRng.HighlightColorIndex = wdTurquoise
                oRng.Collapse 0
            Loop
        End With
    Next lngRows
lbl_Exit:
    Exit Sub
End Sub

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 & "]"
    Set CN = CreateObject("ADODB.Connection")

    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=NO;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

2. Copy the highlighted text (which must be in bold font and Times New Roman) to another Word document.

Code:

Sub CopyHighlightsToOtherDoc()
    Dim ThisDoc As Document
    Dim ThatDoc As Document
    Dim r As Range
    Set ThisDoc = ActiveDocument
    Set r = ThisDoc.Range
    Set ThatDoc = Documents.add
    With r
        With .Find
            .Text = ""
            .Highlight = True
            .Font.Name = "Times New Roman"
            .Font.Bold = True
        End With
        Do While .Find.Execute(Forward:=True) = True
            ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
            ThatDoc.Range.InsertParagraphAfter
            .Collapse 0
        Loop
    End With
   
End Sub

3. Remove all highlights from the original and new Word document.
4. Copy the text from the second Word document and paste it into Excel.

I've tried using several macros to accomplish this, but the process is quite time-consuming. I'm hoping that someone can help me write a VBA macro that can automate this process and make it more efficient.

Any help or suggestions would be greatly appreciated. Thank you!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to copy text from Word to Excel according to a list?	syl3786	Word VBA	6	04-09-2023 08:01 AM
Text To Copy From Excel To Relevant Word Document	Covert Codger	Word VBA	4	07-27-2022 11:40 PM
a macro that can copy data from copy.xls to our current excel macro.xls based on criteria:	udhaya	Excel Programming	1	11-12-2015 10:12 AM
how to copy addresses in word document to excel/mailmerge list	msnarayanan	Mail Merge	4	10-17-2015 03:17 PM
Copy Underline text from Word and Paste into excel	rfaris	Excel Programming	7	10-05-2015 05:56 AM