Copy highlighted words from Word Document to designated Excel file

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

Hi everyone,

I'm working on a project where I need to copy certain words that are highlighted in a Word document to a designated Excel file. I'm not very familiar with writing macros, so I was wondering if anyone could help me with this.

Here's a macro I found online that can copy highlighted text from Word Document to Excel, but it automatically open a new excel file, not allow to paste the copied words to designated excel file.

Code:

Sub ExtractHighShadeText()
Dim Exc As Excel.Application
Dim Wb As Excel.Workbook
Dim Ws As Excel.Worksheet
Dim s As String, Rw As Long
Set Exc = CreateObject("Excel.Application")
Exc.Visible = True
Set Wb = Exc.Workbooks.add
Set Ws = Wb.Sheets(1)
Rw = 0

Dim Rng As Range, StartChr As Long, EndChr As Long, OldColor As Long, Clr As Long
''''''''''''''''''''HiLight''''''''''''''''''
Set Rng = ActiveDocument.Characters(1)
OldColor = Rng.Font.Color
Selection.HomeKey Unit:=wdStory

        With Selection.Find
            .ClearFormatting
            .Text = ""
            .Highlight = True
            .Font.BOLD = True
            Do While .Execute

            'These two line Converting HighlightColorIndex to RGB Color
            Rng.Font.ColorIndex = Selection.Range.HighlightColorIndex
            Clr = Rng.Font.Color

            Rw = Rw + 1
            Ws.Cells(Rw, 1).value = Selection.Text
            'Ws.Cells(Rw, 1).Interior.ColorIndex = Selection.Range.HighlightColorIndex
            Ws.Cells(Rw, 1).Interior.Color = Clr
            'For sorting on HighlightColorIndex
            'Ws.Cells(Rw, 2).Value = Selection.Range.HighlightColorIndex
            'For sorting on HighlightColorIndex RGB value
            Ws.Cells(Rw, 2).value = Clr
            Loop
        End With
Rng.Font.Color = OldColor
'''End Hilight''''''''''''''''''''''''''''''

'WorkAround used for converting highlightColorIndex to Color RGB value
StartChr = 1
EndChr = 0
Set Rng = ActiveDocument.Characters(1)

Selection.HomeKey Unit:=wdStory
        With Selection.Find
            .ClearFormatting
            .Text = ""

            '.Highlight = True
            .Font.Shading.BackgroundPatternColor = wdColorAutomatic

            Do While .Execute
              EndChr = Selection.Start
              Debug.Print Selection.Start, Selection.End, StartChr, EndChr, IIf(EndChr > StartChr, "-OK", "")

              If EndChr > StartChr Then
              Set Rng = ActiveDocument.Range(Start:=StartChr, End:=EndChr)
              Clr = Rng.Font.Shading.BackgroundPatternColor
              Rw = Rw + 1
              Ws.Cells(Rw, 1).value = Rng.Text
              Ws.Cells(Rw, 1).Interior.Color = Clr
              Ws.Cells(Rw, 2).value = Clr
              End If
              StartChr = Selection.End
            Loop

              If EndChr > StartChr Then
              Set Rng = ActiveDocument.Range(Start:=StartChr, End:=EndChr)
              Clr = Rng.Font.Shading.BackgroundPatternColor
              Rw = Rw + 1
              Ws.Cells(Rw, 1).value = Rng.Text
              Ws.Cells(Rw, 1).Interior.Color = Clr
              Ws.Cells(Rw, 2).value = Clr
              End If

        End With


    If Rw > 1 Then
    Ws.Range("A1:B" & Rw).Sort Key1:=Ws.Range("B1"), Order1:=xlAscending, Header:=xlNo
    Ws.Range("B1:B" & Rw).ClearContents
    End If
End Sub

And I know the following code can allow me to designate the excel file:

Code:

Private strWorkbook As String
Private strSheet As String

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

strSheet = "sheet1"

Code:

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

If anyone could provide guidance on how to write this macro, or point me towards any resources that might be helpful, I would really appreciate it. Thank you!

Journeyman · #2 07-26-2023, 07:13 PM

This is a very easy method to find highlighted text in your word document

Code:

Sub Runme()
'Note that this code is written into a word VBE. You could just as easy write something similar into excel.

Dim w As Variant
    For Each sentence In ActiveDocument.StoryRanges
        For Each w In sentence.Words
             'Returns a bolded word
            If w.Font.Bold = True Then Debug.Print "Bold: " & w
             'Returns a highlighted word
            If w.HighlightColorIndex > 0 Then Debug.Print "Hightlight: " & w
        Next
    Next
End Sub

I previously replied to another post today, which will explain how to copy text into an excel file. The post is written for excel, and is for code run in excel, but will give you a good idea how to copy information from Word into Excel:

https://www.msofficeforums.com/word-...text-word.html

Give it a go and see where you end up.

syl3786 · #3 07-26-2023, 11:56 PM

Quote:

Originally Posted by Journeyman

This is a very easy method to find highlighted text in your word document

Code:

Sub Runme()
'Note that this code is written into a word VBE. You could just as easy write something similar into excel.

Dim w As Variant
    For Each sentence In ActiveDocument.StoryRanges
        For Each w In sentence.Words
             'Returns a bolded word
            If w.Font.Bold = True Then Debug.Print "Bold: " & w
             'Returns a highlighted word
            If w.HighlightColorIndex > 0 Then Debug.Print "Hightlight: " & w
        Next
    Next
End Sub

I previously replied to another post today, which will explain how to copy text into an excel file. The post is written for excel, and is for code run in excel, but will give you a good idea how to copy information from Word into Excel:

https://www.msofficeforums.com/word-...text-word.html

Give it a go and see where you end up.

Thank you for your reply. I already have the macro to highlight text in Word Document. What I want is to add the "Browse function" into the following macro, so that I can decide which Excel Sheet should the macro paste the copied text.

Here's a macro I found online that can copy highlighted text from Word Document to Excel, but it automatically open a new excel file, not allow to paste the copied words to designated excel file.

Code:

Sub ExtractHighShadeText()
Dim Exc As Excel.Application
Dim Wb As Excel.Workbook
Dim Ws As Excel.Worksheet
Dim s As String, Rw As Long
Set Exc = CreateObject("Excel.Application")
Exc.Visible = True
Set Wb = Exc.Workbooks.add
Set Ws = Wb.Sheets(1)
Rw = 0

Dim Rng As Range, StartChr As Long, EndChr As Long, OldColor As Long, Clr As Long
''''''''''''''''''''HiLight''''''''''''''''''
Set Rng = ActiveDocument.Characters(1)
OldColor = Rng.Font.Color
Selection.HomeKey Unit:=wdStory

        With Selection.Find
            .ClearFormatting
            .Text = ""
            .Highlight = True
            .Font.BOLD = True
            Do While .Execute

            'These two line Converting HighlightColorIndex to RGB Color
            Rng.Font.ColorIndex = Selection.Range.HighlightColorIndex
            Clr = Rng.Font.Color

            Rw = Rw + 1
            Ws.Cells(Rw, 1).value = Selection.Text
            'Ws.Cells(Rw, 1).Interior.ColorIndex = Selection.Range.HighlightColorIndex
            Ws.Cells(Rw, 1).Interior.Color = Clr
            'For sorting on HighlightColorIndex
            'Ws.Cells(Rw, 2).Value = Selection.Range.HighlightColorIndex
            'For sorting on HighlightColorIndex RGB value
            Ws.Cells(Rw, 2).value = Clr
            Loop
        End With
Rng.Font.Color = OldColor
'''End Hilight''''''''''''''''''''''''''''''

'WorkAround used for converting highlightColorIndex to Color RGB value
StartChr = 1
EndChr = 0
Set Rng = ActiveDocument.Characters(1)

Selection.HomeKey Unit:=wdStory
        With Selection.Find
            .ClearFormatting
            .Text = ""

            '.Highlight = True
            .Font.Shading.BackgroundPatternColor = wdColorAutomatic

            Do While .Execute
              EndChr = Selection.Start
              Debug.Print Selection.Start, Selection.End, StartChr, EndChr, IIf(EndChr > StartChr, "-OK", "")

              If EndChr > StartChr Then
              Set Rng = ActiveDocument.Range(Start:=StartChr, End:=EndChr)
              Clr = Rng.Font.Shading.BackgroundPatternColor
              Rw = Rw + 1
              Ws.Cells(Rw, 1).value = Rng.Text
              Ws.Cells(Rw, 1).Interior.Color = Clr
              Ws.Cells(Rw, 2).value = Clr
              End If
              StartChr = Selection.End
            Loop

              If EndChr > StartChr Then
              Set Rng = ActiveDocument.Range(Start:=StartChr, End:=EndChr)
              Clr = Rng.Font.Shading.BackgroundPatternColor
              Rw = Rw + 1
              Ws.Cells(Rw, 1).value = Rng.Text
              Ws.Cells(Rw, 1).Interior.Color = Clr
              Ws.Cells(Rw, 2).value = Clr
              End If

        End With


    If Rw > 1 Then
    Ws.Range("A1:B" & Rw).Sort Key1:=Ws.Range("B1"), Order1:=xlAscending, Header:=xlNo
    Ws.Range("B1:B" & Rw).ClearContents
    End If
End Sub

And I know the following code can allow me to designate the excel file:

Code:

Private strWorkbook As String
Private strSheet As String

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

strSheet = "sheet1"

Code:

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Highlight word document with words from .txt file	Big_Sugah	Word VBA	11	01-24-2023 02:15 PM
How to use Word Macro to change all highlighted words as mark-up?	hcl75	Word VBA	3	10-08-2022 02:39 PM
Copy words from word to excel	TA9523	Word VBA	13	01-30-2021 06:50 AM
Macro to highlight repeated words in word file and extract into excel file	aabri	Word VBA	1	06-14-2015 07:20 AM
How to copy automatically data from Excel file to Word file?	fuchsd	Word	6	10-25-2011 05:52 AM