Search code examples
vbareplacems-wordhighlightinformation-extraction

VBA MS-WORD load all the yellow highlighted texts in variable array

I would like to run a macro that would extract all the yellow highlighted text of the document and pass all those highlighted text into an array variable.

I found this link: How to perform a selective extraction of text highlighted in yellow from an MS Word document?

but the solution proposed does not work and is not exactly the same.

So basically the logic would be:

look up all the document count how many highlighted pices of text there are

Dim CountYellow as integer
Dim HltText as variant
'i dont know how to do this next:
countyellow= number of highlighted texts
redim HltText(1 to countyellow)
for i=1 to countyellow
'I dont know how to do this next:
FIND THE NEXT YELLOW HIGHLIGHTED TEXT
HltText(i)= HIGHLIGHTED TEXT
next i

Thanks a lot

PS; after I re-read my question I would like to add here for clarification. the text would be something like this:

Lorem ipsum dolor sit amet, THIS TEXT IS YELLOW HIGHLIGHTED consectetur adipiscing elit. Curabitur iaculis vehicula arcu, accumsan facilisis eros sagittis sed. Duis sit amet diam sit amet magna pharetra molestie. Cras sagittis lacus non tortor accumsan accumsan commodo at mi. Ut ipsum nunc, suscipit at elit quis, auctor rutrum diam. Mauris vel dictum dolor. Quisque THIS SECOND TEXT IS YELLOW HIGHLIGHTED porta a purus in sodales. Pellentesque accumsan ac tellus a molestie. Duis tempor sapien enim, eu THIS ANOTHER TEXT AS WELL IS HIGHLIGHTED sollicitudin turpis volutpat sit amet. Ut libero dui, dapibus in vulputate vitae, aliquet vel turpis. Donec nec congue est. In enim turpis, scelerisque id condimentum ac, porta quis tellus.

where then: HltText(1)="THIS TEXT IS YELLOW HIGHLIGHTED" HltText(2)="HIS SECOND TEXT IS YELLOW HIGHLIGHTED" etc...

Solution

  • Something like this perhaps?

    Sub Highlights()
'
' Highlights Macro
'
Dim rng As Variant
Dim strResults(1000) As String
Dim intIndex As Integer

Set wordapp = CreateObject("word.Application")
    wordapp.documents.Open "C:\filename.docx"
    wordapp.Visible = True

Set rng = wordapp.ActiveDocument.Content
rng.Find.Forward = True
rng.Find.Highlight = True
rng.Find.Execute

intIndex = 0
Do While rng.Find.Found = True
    Debug.Print (rng.Text)
    strResults(intIndex) = rng.Text
    rng.Find.Execute
Loop

    End Sub