Я хочу скопировать весь выделенный и заштрихованный текст из файла Word в Excel вместе с цветами через VBA

Question

Я хочу скопировать весь выделенный и затененный текст из файла Word в Excel с тем же цветом в файле Word через VBA.

Мне удалось скопировать только выделенный текст из слова в слово. Но реальная задача - скопировать весь выделенный и заштрихованный текст в 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