Word VBA для копирования определенных выделенных цветов и вставки в новый документ без потери форматирования

Question

У меня есть текстовый документ на 180 страниц, в котором все цвета выделены случайным образом по всему документу. Документ имеет несколько различных форматов: курсив, маркеры и подчеркивание, а также шрифты разных размеров.

Я пытаюсь отфильтровать документ, выбрать все абзацы с выделением определенного цвета и вставить его в новый документ, сохранив все форматирование. Затем он повторяется снова, выбирает выделение следующего цвета и вставляет его в тот же новый документ с разрывом страницы между ними или просто в новый документ все вместе. Я пытался понять это в течение 2 дней.

Я попробовал формулы из этого Word VBA скопировать выделенный текст в новый документ и сохранить форматирование и другие в переполнении стека, но ни одно из них не сохраняет все форматирование или то, которое я нашел, я мог получить только это скопировать весь документ с форматированием и вставить, но не выделенные блики.

Этот делает свое дело, но он удаляет все форматирование и не может понять, как разместить разрыв страницы.

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

'Этот экземпляр копирует только весь текст в документе, а не просто highliteColor, запрашиваемый

    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

Я ожидаю, что выходные данные скопируют весь текст, который имеет определенный цвет выделения, вставят его в новый документ, сохраняющий все форматирование, а затем разбивают его на страницы. Вернитесь, выберите следующий выделенный цвет и вставьте в документ, пока все цвета не будут получены.

Answer 1

Я внес коррективы в ваш код на основе того, что, как я понимаю, вы хотите сделать.В некоторых случаях я пытался сделать его немного более читабельным, например, я удалил один из методов With.

Посмотрите внимательно на использование FormattedText и как он переносится из одного диапазона в другой.А также посмотрите в конце процедуры, как вставить разрыв страницы.

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