Word VBA 将突出显示的文本复制到新文档并保留格式答案

【问题标题】：Word VBA copy highlighted text to new document and preserve formattingWord VBA 将突出显示的文本复制到新文档并保留格式
【发布时间】：2017-02-14 20:21:24
【问题描述】：

我有一个包含多个突出显示的单词的 word 文档，我想将其复制到另一个 word 文件中。我使用的代码工作正常，但不保留源文档中的原始格式。这是整个代码（第一部分使用通配符查找单词并突出显示它们，第二部分查找突出显示的单词并将它们复制到新的 Word 文档中）：

Sub testcopytonewdoc2()
'
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r, newr, destr As Range
Dim rangestart, rangeend As Long

Set r = ActiveDocument.Range
rangeend = r.Characters.Count

r.Find.Execute FindText:="39.13 [Amended]"
rangestart = r.Start

'find words and highlight them
x = 0
Do While x < 4
Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdYellow
 With ActiveDocument.Content.Find
  '.ClearFormatting
  If x = 0 Then
  .text = "[!)][(][1-9][)]?{7}"
  ElseIf x = 1 Then
  .text = "[!?][(][a-z][)][ ][A-Z]?{6}"
  ElseIf x = 2 Then
  .text = "[!?][(][ivx]{2}[)][ ][A-Z]?{6}"
  Else
  .text = "[!?][(][ivx]{3}[)][ ][A-Z]?{6}"
  End If
  With .Replacement
   ' .ClearFormatting
    .Highlight = True
  End With
  .Forward = True
  .Wrap = wdFindContinue
  .Format = True
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
x = x + 1
Loop

Set ThisDoc = ActiveDocument
Set newr = ThisDoc.Range
Set ThatDoc = Documents.Add

newr.SetRange Start:=rangestart, End:=rangeend  

'find highlighted words and add to a new document (preserve BOLD font):

With newr.Find
.text = ""
.Highlight = True
.Format = True
.Wrap = wdFindStop
  While .Execute
    Set destr = ThatDoc.Range
    destr.Collapse wdCollapseEnd
    destr.FormattedText = newr.FormattedText
    ThatDoc.Range.InsertParagraphAfter
    newr.Collapse wdCollapseEnd
  Wend
End With
Application.ScreenUpdating = True

End Sub

有人可以帮忙吗？突出显示的单词是粗体和非粗体文本的混合，保持这种差异很重要。提前感谢您的帮助！

冬青

【问题讨论】：

似乎更容易复制所有内容并替换其他所有内容

标签： vba ms-word

【解决方案1】：

试试这个方法。

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

这来自我的书。

http://www.lulu.com/shop/ryan-shuell/ebook/product-22936385.html

【讨论】：