Macro to search for a particular word and copy it to a new document

[Teacakescc]

Hi Everyone, I hope someone can help me with a problem I’m having. I have put together the following macro by recording a macro and adding bits from forums etc.

I have a document with a list of items (e.g. shopping list). I will open it once a day, and put markers next to certain items. Then I need the macro to search for these markers i.e. “zzz” and copy that entire line to a new document.

Now I should have a list on a new document, all with “zzz” next to each item. I then need to replace this text (“zzz”) with a space (or even remove it).

Once both the lists have been cleaned up, the main document can be saved and ready for use the next day. And the ‘clean’ list on the new document can then be used for other things. This file won’t be saved as the data will be used elsewhere.

It works great for what I want it to do, apart from cleaning up the data. For some reason it does not remove the “zzz” from either documents.

This is the code I have so far.

Thanks in advance

Sub ShoppingList()
' Macro to search for a particular word, copy that entire
' paragraph/line and paste it into a New document.
' Then find the search word in both douments and remove it.
 
Dim wDoc1 As Document
Dim wDoc2 As Document
Dim sFnd As String
 
' Create a New document
Set wDoc1 = ActiveDocument: Set wDoc2 = Documents.Add
sFnd = "zzz"
Application.ScreenUpdating = False
 
    With wDoc1.Range
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = "zzz"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
        End With
        Do While .Find.Found
            ' Paste that entire paragraph/line into a New document
            wDoc2.Characters.Last.FormattedText = .Paragraphs(1).Range.FormattedText
            .End = .Paragraphs(1).Range.End
            .Collapse wdCollapseEnd
            .Find.Execute
        Loop
        Application.ScreenUpdating = True
    End With
   
    ' Remove 'search' word from wdoc1
    Selection.Find.Replacement.ClearFormatting
    With wDoc1.Range
       With .Find
            .Text = "zzz"
            .Replacement.Text = " "
            .Forward = True
            .Wrap = wdFindAsk
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    ' remove 'search' word from wdoc2
    Selection.Find.Replacement.ClearFormatting
    With wDoc2.Range
        With .Find
            .Text = "zzz"
            .Replacement.Text = " "
            .Forward = True
            .Wrap = wdFindAsk
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
           .MatchAllWordForms = False
        End With
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Dim CopiedData As String
    ' copy all the text in the new document
    CopiedData = ActiveDocument.Content.Text
    ' display the contents of the new document in a message box.
    MsgBox copiedData
End Sub

[gmayor]

The following will work

Sub ShoppingList()
'Graham Mayor - https://www.gmayor.com - Last updated - 01 Sep 2020
Dim oDoc As Document, oTarget As Document
Dim oRng As Range, oPara As Range
    Set oDoc = ActiveDocument
    Set oTarget = Documents.Add
    Set oRng = oDoc.Range
    With oRng.Find
        Do While .Execute(findText:="zzz")
            oRng.MoveEndWhile Chr(32)
            Set oPara = oRng.Paragraphs(1).Range
            oTarget.Range.InsertAfter (Trim(Replace(oPara.Text, "zzz", "")))
            oRng.Text = ""
            oRng.Collapse 0
        Loop
    End With
    MsgBox oTarget.Range.Text
    Set oDoc = Nothing
    Set oTarget = Nothing
    Set oRng = Nothing
    Set oPara = Nothing
End Sub

[Teacakescc]

Thank you so much Graham!!! It works pefectly. And your code is so much more efficient. I'm in awe....