CODEWITHSUNDEEP
vbams-word
Thorson
Thorson

Reputation: 11

Word VBA copy highlighted text to new document and preserve formatting

I have a word document with multiple highlighted words that I want to copy into another word file. The code I'm using works fine, but does not preserve the original formatting in the source document. Here's the entire code (1st section finds words using wildcards and highlights them, and the 2nd section finds the highlighted words and copies them to a new word document):

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

Can anyone help? The highlighted words are a mix of bold and non-bold text and it's important to maintain this difference. Thanks in advance for your help!

Holly

Upvotes: 1

Views: 1300

Answers (1)

ASH
ASH

Reputation: 20302

Try it this way.

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

This comes from my book.

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

Upvotes: 1

Related Questions