Macro for batch replacements (with format changes-) - including subfolders

[Cubajz]

Hi I´m using this macro for running some replacements in Word documents - it works good for all documents in SINGLE FOLDER. I was wondering if someone could help me modify it - so it would run also through documents which are in SUBFOLDERS. Thank you for any help :hi:


Sub Replace001()
Dim Directory As String
Dim FType As String
Dim FName As String


Directory = "C:\Files_For_Replacement"
FType = "*.docx"


ChDir Directory
FName = Dir(FType)
' for each file you find, run this loop
Do While FName <> ""
' open the file
Documents.Open FileName:=FName


' search and replace specific text 1
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.Bold = True
.Color = wdColorRed
End With
With Selection.Find
.Text = "Hello"
.Replacement.Text = "Hi2"
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll


' search and replace specific text 2
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.Bold = True
.Color = wdColorGreen
End With
With Selection.Find
.Text = "Mouse"
.Replacement.Text = "Lion2"
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll


' save and close the current document
ActiveDocument.Close wdSaveChanges


' look for next matching file
FName = Dir
Loop
End Sub

[gmaxey]

You could use the add-in here and adapt your current code to meet the requirements of a user defined process.
http://gregmaxey.com/word_tip_pages/process_batch_folder_addin.html

[Cubajz]

Thank you for answering. I´m already familiar with your add-in (which is awesome btw:thumb), but I´m really a begginner and I´m strugling to understand how to ADAPT my macro (so it "meets the requirements of a user defined process").
May I kindly ask you for help with writting this macro, so I can you use it with add-in? My hope is I´ll be able to learn how to modify it on my own - for example using diferent text, colors, bold/italic font, etc. for searching and replacing- in my future projects. It would really help me a lot. Thanks again.

[gmayor]

You need to add the sub folders to a collection and process the members of the collection. There's an example at http://stackoverflow.com/questions/28629495/vba-to-loop-through-files-in-subfolders albeit for Excel, the premise is the same for Word.

You can then modify your macro as follows:


Sub Replace001(Directory As String)
Dim FType As String
Dim FName As String
Dim oRng As Range
Dim oDoc As Document
Do Until Right(Directory, 1) = Chr(92)
Directory = Directory & Chr(92)
Loop
FType = Directory & "*.docx"
FName = Dir(FType)
' for each file you find, run this loop
Do While FName <> ""
' open the file
Set oDoc = Documents.Open(FileName:=Directory & FName)
Set oRng = oDoc.Range
With oRng.Find
Do While .Execute(FindText:="Hello", MatchWholeWord:=True, MatchCase:=True)
oRng.Text = "Hi2"
With oRng.Font
.Bold = True
.Color = wdColorRed
End With
oRng.Collapse 0
Loop
End With

Set oRng = oDoc.Range
With oRng.Find
Do While .Execute(FindText:="Mouse", MatchWholeWord:=True, MatchCase:=True)
oRng.Text = "Lion2"
With oRng.Font
.Bold = True
.Color = wdColorGreen
End With
oRng.Collapse 0
Loop
End With
' save and close the current document
oDoc.Close wdSaveChanges
FName = Dir
Loop
End Sub This is then called from your loop e.g.


Replace001 "C:\Path\Forums"

However using the batch macro, you have to supply a document level userdefined process. Without going there to check, I am certain that Greg describes this on his web site, and I certainly do with the essentially similar jointly developed process on my web site http://www.gmayor.com/document_batch_processes.htm (http://www.gmayor.com/document_batch_processes.htm)

However to adapt the above macro to do that you need to remove the folder level loop and set the process the document e.g. as follows. It also needs to be a function to return a value.


Function Replace002(oDoc As Document) As Boolean
Dim oRng As Range
On Error GoTo err_handler
Set oRng = oDoc.Range
With oRng.Find
Do While .Execute(FindText:="Hello", MatchWholeWord:=True, MatchCase:=True)
oRng.Text = "Hi2"
With oRng.Font
.Bold = True
.Color = wdColorRed
End With
oRng.Collapse 0
Loop
End With

Set oRng = oDoc.Range
With oRng.Find
Do While .Execute(FindText:="Mouse", MatchWholeWord:=True, MatchCase:=True)
oRng.Text = "Lion2"
With oRng.Font
.Bold = True
.Color = wdColorGreen
End With
oRng.Collapse 0
Loop
End With
Replace002 = True
lbl_Exit:
Exit Function
err_handler:
Replace002 = False
Resume lbl_Exit
End Function
This includes some additional code to interface with the logging. Checkout the replacement functions in the batch process add-ins.

[Cubajz]

This works like a charm! Thank you so much for your solution:bow:. This is great.

Only If I may ask: I cannot figure out how to (where to) write font specifications for FIND text - for example: I want to FIND italic and red text and replace it with bold and black. Something like this in simple code:


Sub ReplacingSpecificColors()
Selection.Find.ClearFormatting
With Selection.Find.Font
.Italic = True
.Color = wdColorRed
End With
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.Bold = True
.Italic = False
.Color = wdColorBlue
End With
With Selection.Find
.Text = "Mouse"
.Replacement.Text = "Lion"
.Forward = True
.Wrap = wdFindContinue
.Format = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub


Can you help one last time to put this format specifications into your previously writen function (so I can use it in batch)? Having option to specify format of text I´m FINDING is crucial for my next project as well.:content: Thanks.

[gmaxey]

Since you are doing a replacement and not manipulating the found range, you don't have to loop you can use something like this:


Function Replace002(oDoc As Document) As Boolean
Dim oRng As Range
On Error GoTo err_handler
Set oRng = oDoc.Range
With oRng.Find
.Text = "test" 'word to find
.MatchWholeWord = True
.MatchCase = True
.Font.Italic = True
.Font.Color = wdColorRed
With .Replacement
.Text = "test" 'replacement word
.Font.Italic = False
.Font.Bold = True
.Font.Color = wdColorAutomatic
End With
.Execute Replace:=wdReplaceAll
End With
'Repeat as required e.g.,
'Set oRng = oDoc.Range
'...
Replace002 = True
lbl_Exit:
Exit Function
err_handler:
Replace002 = False
Resume lbl_Exit
End Function

Note: As written (Graham's original and revised above), the VBA find and replace macro only process the main text storyrange of the document. If you need to process, headers\footers, footnotes, etc. Post back.

[Cubajz]

Thanks it works great and I myself don´t really need it to search through headers, footers etc. I feel like I already learned a bit from your work, but can I have one more request? I´m struggling how to adapt this simple macro to function, so I can use it in batch add-in. Maybe with another example of yours, the process will be clearer to me:
Macro to adapt:

Sub ApplyTableWidth()
Dim tbl As Table
For Each tbl In ActiveDocument.Tables
tbl.PreferredWidthType = wdPreferredWidthPoints
tbl.PreferredWidth = CentimetersToPoints(17.5)
tbl.LeftPadding = CentimetersToPoints(0.07)
tbl.RightPadding = CentimetersToPoints(0.07)
tbl.Spacing = 0
tbl.AllowPageBreaks = True
tbl.AllowAutoFit = False
Next
End Sub

[gmaxey]

Function ApplyTableWidth(oDoc As Document) As Boolean
Dim oTbl as Table
On Error GoTo err_handler
For Each oTbl In oDoc.Tables
With oTbl
.PreferredWidthType = wdPreferredWidthPoints
.PreferredWidth = CentimetersToPoints(17.5)
.LeftPadding = CentimetersToPoints(0.07)
.RightPadding = CentimetersToPoints(0.07)
.Spacing = 0
.AllowPageBreaks = True
.AllowAutoFit = False
End With
Next oTbl
ApplyTableWidth = True
lbl_Exit:
Exit Function
err_handler:
ApplyTableWidth = False
Resume lbl_Exit
End Function