Question

我有一个180页的Word文档，并且在整个文档中随机使用所有突出显示的颜色。该文档上有几种不同的格式，包括斜体，项目符号和下划线以及不同大小的字体。

我想做的是通过文档进行筛选，选择所有包含特定颜色突出显示的段落，然后将其粘贴到新文档中，以保持所有格式不变。然后，它再次循环遍历并选择下一个颜色突出显示并将其粘贴到同一新文档中，并且之间要有分页符，或者只是将新文档放在一起。我已经尝试了2天。

我已经尝试过Word VBA copy highlighted text to new document and preserve formatting中的公式以及Stack Overflow上的其他公式，但是它们都不保存所有格式，或者我发现我只能用格式复制整个文档并粘贴，但是不是选定的重点。

这是个窍门，但它删除了所有格式，并且不知道如何放置分页符。

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

Word VBA可复制某些突出显示的颜色并粘贴到新文档中，而不会丢失格式

1 个答案: