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