文章/答案/技术大牛

发布

社区首页 >问答首页 >将突出显示的文本复制/粘贴到新的不同文档中

问将突出显示的文本复制/粘贴到新的不同文档中
EN

Stack Overflow用户

提问于 2022-06-29 20:40:43

回答 1查看 65关注 0票数 0

我使用Word文档，这些文档以多种颜色突出显示。我需要的是VBA找到一个突出显示的部分并将该文本粘贴到一个新的文档中，找到下一个高亮显示的部分，并在一个新的(不同的)文档中复制该文本。我的代码可用于Word中的所有15种颜色的高亮显示。但是，即使该颜色不存在于文本中，它也会为该颜色创建一个新文档。所以每次我运行我的代码，我就会得到15个新文档。

如果该颜色不存在，则需要代码忽略突出显示颜色，同时仍然为文档中的颜色创建新的(和不同的)文档。

例如，我可能会得到一个只有蓝色和绿色高亮显示文本的文档，因此我需要两个新文档。或者我可能会得到一个用蓝色、绿色、黄色和红色高亮显示文本的文档，所以我需要四个新的焦点，每个颜色一个。

对我需要改变的东西有什么想法吗？

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, wdBlack, wdBlue, wdBrightGreen, wdDarkBlue, wdDarkRed, wdDarkYellow, wdGreen, wdPink, wdRed, wdTeal, wdTurquoise, wdViolet, wdWhite)

Set objDoc = ActiveDocument
For i = LBound(highliteColor) To UBound(highliteColor)
    Set objDocAdd = Documents.Add
    Set objRange = objDocAdd.Content
    objRange.Collapse wdCollapseEnd
    objDoc.Activate
    Selection.HomeKey unit:=wdStory
    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 wdCollapseEndwdYellow
                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

vba

ms-word

copy-paste

highlight

回答 1

Stack Overflow用户

发布于 2022-06-29 21:30:17

我认为，如果您将代码拆分一点，这将更容易管理:首先收集所有突出显示的范围，然后处理它们。

这应该很近。

Sub TestDoc()
    
    Dim col As Collection, rng As Range, dict As Object, hc As String
    Dim doc As Document, destRng As Range
    
    Set dict = CreateObject("scripting.dictionary") 'for tracking documents vs highlight colors
    
    Set col = HighlightedRanges(ActiveDocument)     'first get all highlighted ranges
    For Each rng In col
        hc = CStr(rng.HighlightColorInde     'get the highlight color
        If Not dict.Exists(hc) Then          'need a new doc for this one?
            dict.Add hc, Documents.Add       'add doc and key to highlight color
        End If
        Set doc = dict(hc)                   'get doc for this color
        Set destRng = doc.Content            'copy the content over...
        destRng.Collapse Direction:=wdCollapseEnd
        destRng.InsertParagraphAfter
        destRng.Collapse Direction:=wdCollapseEnd
        destRng.FormattedText = rng.FormattedText
    Next rng
End Sub


'return a collection of all highlighted ranges in `doc`
Function HighlightedRanges(doc As Document) As Collection
    Dim rng As Range, col As New Collection
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Forward = True
        .Format = True
        .Highlight = True
        .Wrap = wdFindStop
        Do While .Execute
            col.Add doc.Range(rng.Start, rng.End) 'clone the range
        Loop
    End With
    Set HighlightedRanges = col  'return all the found ranges
End Function

票数 0

页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持

原文链接：

https://stackoverflow.com/questions/72807601

复制

相似问题

问将突出显示的文本复制/粘贴到新的不同文档中
EN

回答 1

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问将突出显示的文本复制/粘贴到新的不同文档中EN

回答 1

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问将突出显示的文本复制/粘贴到新的不同文档中
EN