I want to copy all highlighted and shaded text from Word file to Excel along with the colors through VBA - vba

Question

I want to copy all Highlighted and Shaded text from Word file to Excel with same color in Word file through VBA.
I was able to copy only highlighted text from word to word. But the actual task is to copy all highlighted and shaded text to Excel and sort all the data according to color in Excel.
I use this code and it works fine to just copy from word to word but there is no formatting this code copies only text no colors;
Sub ExtractHighlightedText()
Dim oDoc As Document
Dim s As String
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = ""
.Highlight = True
Do While .Execute
s = s & Selection.Text & vbCrLf
Loop
End With
End With
Set oDoc = Documents.Add
oDoc.Range.InsertAfter s
End Sub
Code for converting from Shaded to Highlighted:
Sub ConvertTextsFromShadedToHighlighted()
Dim objParagraph As Paragraph
Dim objCharacterRange As Range
For Each objParagraph In ActiveDocument.Paragraphs
If objParagraph.Range.Information(wdWithInTable) = False Then
If objParagraph.Range.Shading.BackgroundPatternColor <> wdColorAutomatic
Then
objParagraph.Range.Shading.BackgroundPatternColor = wdColorAutomatic
objParagraph.Range.HighlightColorIndex = wdPink
End If
End If
Next objParagraph
For Each objCharacterRange In ActiveDocument.Characters
if objCharacterRange.Font.Shading.BackgroundPatternColor <>
wdColorAutomatic Then
objCharacterRange.Font.Shading.BackgroundPatternColor = wdColorAutomatic
objCharacterRange.HighlightColorIndex = wdPink
End If
Next objCharacterRange
End Sub

Answer 1

May try something like this
Edit: Tried to include Extraction of Shaded text (Any color) along with Highlighted text by using tow finds. Following workaround methods are adopted
For finding Shaded text (of any color) find is executed for .Font.Shading.BackgroundPatternColor = wdColorAutomatic and the range excluding that selection was picked up as shaded text and color. Method somehow crudely performing when selection contain pure text characters but still picking up wrong color value when selection contain non text characters (i.e. paragraph marks etc). Otherwise it is working up to expectation. Otherwise there is always another option open to iterate through all the characters in the documents. But that option was left out as it is very slow and impractical for large documents.
As no simple method (or property) found by me to convert HighlightColorIndex to RGB color value, The same was applied to one character's Font.ColorIndex and later extracted as Font.Color
So finally the solution become messy and somehow crude, I am not at all satisfied with and more answers are invited from experts for simple direct solutions in these regards.
Code:
Option Explicit
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
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