View Single Post
 
Old 07-26-2023, 11:56 PM
syl3786 syl3786 is offline Windows 10 Office 2019
Advanced Beginner
 
Join Date: Jan 2023
Posts: 97
syl3786 is on a distinguished road
Default

Quote:
Originally Posted by Journeyman View Post
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
Reply With Quote