Word VBA to copy certain highlighted colors and paste in new document with no formatting lost - vba

Question

I have a word document that is 180 pages and uses all the highlight Colors randomly throughout the document. The document has several different formats on it from italics, bullets and underline and different size fonts.
What I am trying to do is filter through the document select all paragraphs that contain a certain color highlight then paste it in a new document keeping all formatting in place. It then loops through again and selects the next color highlight and pastes it in the same new document with a page break in between or just a new document all together. I have been trying to figure this out for 2 days.
I have tried the formulas from this Word VBA copy highlighted text to new document and preserve formatting and other ones on Stack Overflow but none of them preserve all the formatting or one that I found I could only get it to copy the whole document with formatting and paste in but not the selected highlights.
This one does the trick but it removes all formatting and can't figure out how to place page break in.
Sub ExtractHighlightedTextsInSameColor()
Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim strFindColor As String
Dim highliteColor As Variant
highliteColor = Array(wdYellow, wdTeal)
Set objDoc = ActiveDocument
Set objDocAdd = Documents.Add
objDoc.Activate
For i = LBound(highliteColor) To UBound(highliteColor)
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.Highlight = True
Do While .Execute
If Selection.Range.HighlightColorIndex = highliteColor(i) Then
Set objRange = Selection.Range
objDocAdd.Range.InsertAfter objRange & vbCr
Selection.Collapse wdCollapseEnd
End If
Loop
End With
End With
Next
End Sub
'This one only copies all text in document and not just highliteColor asked for
Sub HighlightedColor()
Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim highliteColor As Variant
highliteColor = Array(wdYellow, wdTeal, wdPink)
Set objDoc = ActiveDocument
Set objDocAdd = Documents.Add
objDoc.Activate
For i = LBound(highliteColor) To UBound(highliteColor)
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.Highlight = True
Do While .Execute
If Selection.Range.HighlightColorIndex = highliteColor(i) Then
Set objRange = Selection.Range.FormattedText
objRange.Collapse wdCollapseEnd
objDocAdd.Content.FormattedText = objRange
End If
Loop
End With
End With
Next
End Sub
I expect the output to copy all text that are a certain highlight color, paste them into a new document preserving all formatting and then page break it. Go back select the next highlight color and paste in document until all colors are gotten.

Answer 1

I've made adjustments to your code based on what I understand you want to do. In some cases I tried to make it a little more readable, for example I removed one of the With methods.
Look closely at the use of FormattedText and how it is transferred from one range to another. And also look at the end of the routine for how a page break is inserted.
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, wdTeal)
Set objDoc = ActiveDocument
Set objDocAdd = Documents.Add
Set objRange = objDocAdd.Content
For i = LBound(highliteColor) To UBound(highliteColor)
objDoc.Activate
Selection.HomeKey unit:=wdStory
objRange.Collapse wdCollapseEnd
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 wdCollapseEnd
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