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