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