我想通过VBA将所有突出显示和阴影文本从Word文件复制到Excel以及颜色

Question

我想通过VBA将所有突出显示和着色的文本从Word文件复制到Word文件中具有相同颜色的Excel。

我只能从一个单词复制到另一个单词。但实际任务是将所有突出显示和阴影文本复制到Excel，并根据Excel中的颜色对所有数据进行排序。

我使用此代码，只需从一个单词复制到另一个单词就可以正常工作，但是没有格式，此代码仅复制文本而没有颜色;

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

从阴影转换为突出显示的代码：

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

可以尝试这样的事情

编辑：尝试使用拖曳查找包括提取阴影文本(任何颜色)以及突出显示的文本。采用以下解决方法

1. 为了查找着色文本(任何颜色)，查找将针对.Font.Shading.BackgroundPatternColor = wdColorAutomatic执行，并且不包括该选择的范围被选取为着色文本和颜色。当选择包含纯文本字符时，方法以某种方式粗略执行，但当选择包含非文本字符(即段落标记等)时，仍然会拾取错误的颜色值。否则，它正在达到预期。否则，总会有另一个选项可以循环访问文档中的所有字符。但是该选项被省略了，因为它对于大型文档非常缓慢且不切实际。
2. 由于我没有找到将HighlightColorIndex转换为 RGB 颜色值的简单方法(或属性)，因此同样应用于一个字符的Font.ColorIndex，然后提取为Font.Color

所以最后解决方案变得混乱和粗糙，我一点也不满意，并邀请专家提供更多答案，以获得这些方面的简单直接解决方案。

法典：

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