Word VBA新しい文書にハイライトされたテキストをコピーして書式を保持

Question

私は別の単語ファイルにコピーしたい複数の強調表示された単語を持つ単語文書を持っています。使用しているコードは正常に動作しますが、ソースドキュメントの元の書式は保持されません。ここでは、全体のコードは、（第一節では、ワイルドカードを使用して単語を検索し、それらを強調し、そして第二節では、新しい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 

誰が助けることはできますか？強調表示された単語は、太字と太字ではないテキストが混在しているため、この違いを維持することが重要です。あなたの助けを前もってありがとう！

ホリー

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