Word VBA將突出顯示的文本複製到新文檔並保留格式化

Question

我有一個包含多個突出顯示單詞的單詞文檔，我想將其複製到另一個單詞文件中。我使用的代碼工作正常，但不保留源文檔中的原始格式。這裏就是整個代碼（第一部分找到使用通配符的話，並強調他們，第2節找到高亮顯示的單詞，並將它們複製到一個新的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 

誰能幫助？突出顯示的文字是粗體和非粗體文字的組合，保持這種差異很重要。在此先感謝您的幫助！

Holly

Answer 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