Copy/paste highlighted text into new different documents - vba

Question

I use Word documents which are highlighted in a number of colors. What I need is for the VBA to find a highlighted section and paste that text in a new document, find the next highlighted section in a different color and copy that text in a new (different) document). My code does that for all 15 colors available for highlighting in Word. However, even if the color is not present in the text, it will create a new document for that color. So every time I run my code, I get 15 new documents.
I need the code to ignore a highlight color if that color is not present, while still creating new (and different) documents for the colors that are present in the document.
For example, I might get a document that only has highlighted text in blue and green, so I would need two new documents for that. Or I might get a document that has highlighted text in blue, green, yellow and red, so I would need four new focuments, one for each color.
Any ideas on what I need to change?
Sub ExtractHighlightedTextsInSameColor()
Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim strFindColor As String
Dim highliteColor As Variant
Dim i As Long
highliteColor = Array(wdYellow, wdBlack, wdBlue, wdBrightGreen, wdDarkBlue, wdDarkRed, wdDarkYellow, wdGreen, wdPink, wdRed, wdTeal, wdTurquoise, wdViolet, wdWhite)
Set objDoc = ActiveDocument
For i = LBound(highliteColor) To UBound(highliteColor)
Set objDocAdd = Documents.Add
Set objRange = objDocAdd.Content
objRange.Collapse wdCollapseEnd
objDoc.Activate
Selection.HomeKey unit:=wdStory
With Selection.Find
.ClearFormatting
.Forward = True
.Format = True
.Highlight = True
.Wrap = wdFindStop
.Execute
Do While .Found
If Selection.Range.HighlightColorIndex = highliteColor(i) Then
' the following copies only the highlighted text
objRange.FormattedText = Selection.Range.FormattedText
'if you want the entire paragraph that contains a highlighted text item then use this
' objRange.FormattedText = Selection.Range.Paragraphs(1).Range.FormattedText
Selection.Collapse wdCollapseEndwdYellow
objRange.InsertParagraphAfter
objRange.Collapse wdCollapseEnd
Else
objRange.Collapse wdCollapseEnd
End If
.Execute
Loop
End With
objRange.Collapse wdCollapseEnd
If i < UBound(highliteColor) Then
'added a conditional check so an extra page break is not inserted at end of document
objRange.InsertBreak Word.WdBreakType.wdPageBreak
End If
Next
End Sub

Answer 1

I think this is easier to manage if you split your code up a bit: first collect all of the highlighted ranges, and then process them.
This should be pretty close.
Sub TestDoc()
Dim col As Collection, rng As Range, dict As Object, hc As String
Dim doc As Document, destRng As Range
Set dict = CreateObject("scripting.dictionary") 'for tracking documents vs highlight colors
Set col = HighlightedRanges(ActiveDocument) 'first get all highlighted ranges
For Each rng In col
hc = CStr(rng.HighlightColorInde 'get the highlight color
If Not dict.Exists(hc) Then 'need a new doc for this one?
dict.Add hc, Documents.Add 'add doc and key to highlight color
End If
Set doc = dict(hc) 'get doc for this color
Set destRng = doc.Content 'copy the content over...
destRng.Collapse Direction:=wdCollapseEnd
destRng.InsertParagraphAfter
destRng.Collapse Direction:=wdCollapseEnd
destRng.FormattedText = rng.FormattedText
Next rng
End Sub
'return a collection of all highlighted ranges in `doc`
Function HighlightedRanges(doc As Document) As Collection
Dim rng As Range, col As New Collection
Set rng = doc.Content
With rng.Find
.ClearFormatting
.Forward = True
.Format = True
.Highlight = True
.Wrap = wdFindStop
Do While .Execute
col.Add doc.Range(rng.Start, rng.End) 'clone the range
Loop
End With
Set HighlightedRanges = col 'return all the found ranges
End Function