Mass Find & Replace including subfolders - vba

Question

I don't really know VBA but have had some success with manipulating code in the past. I'm getting stuck with this one, where I tried to mix 2 different ideas into one. What I want to do is a mass find & replace with pop-up boxes to (1) select or insert the path (that includes subfolders); (2) insert the "find text"; (3) insert the "replace text"; and (4) cycle through all .docx files in all subfolders.
I found this code to do what I want on a single folder, but can't figure out how to manipulate it to include subfolders:
Sub FindAndReplaceInFolder()
Dim objDoc As Document
Dim strFile As String
Dim strFolder As String
Dim strFindText As String
Dim strReplaceText As String
' Pop up input boxes for user to enter folder path, the finding and replacing texts.
strFolder = InputBox("Enter folder path here:")
strFile = Dir(strFolder & "\" & "*.docx", vbNormal)
strFindText = InputBox("Enter finding text here:")
strReplaceText = InputBox("Enter replacing text here:")
' Open each file in the folder to search and replace texts. Save and close the file after the action.
While strFile <> ""
Set objDoc = Documents.Open(FileName:=strFolder & "\" & strFile)
With objDoc
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.text = strFindText
.Replacement.text = strReplaceText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End With
objDoc.Save
objDoc.Close
strFile = Dir()
End With
Wend
End Sub
Thanks in advance!

Answer 1

I mean something like this:
Option Explicit
Sub FindAndReplaceInFolder()
Dim colFiles As Collection, f
Dim strFolder As String, strFindText As String, strReplaceText As String
'Pop up input boxes for user to enter folder path, the finding and replacing texts.
'(fixed values for testing...)
strFolder = "C:\Temp\SO\" 'InputBox("Enter folder path here:")
strFindText = "several" 'InputBox("Enter finding text here:")
strReplaceText = "three or four" 'InputBox("Enter replacing text here:")
Set colFiles = GetMatches(strFolder, "*.docx")
For Each f In colFiles
Debug.Print "Processing: " & f
ReplaceInFile CStr(f), strFindText, strReplaceText
Next f
Debug.Print "Processed " & colFiles.Count & " files"
End Sub
'replace all instances of `strFindText` with `strReplaceText` in file at `fPath`
Sub ReplaceInFile(fPath As String, strFindText As String, strReplaceText As String)
Dim doc As Document
Set doc = Documents.Open(fPath)
With doc.Content.Find
.Text = strFindText
.Replacement.Text = strReplaceText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
doc.Close savechanges:=True
End Sub
'Return a collection of file paths given a starting folder and a file pattern
' e.g. "*.docx"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fPath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
fPath = fldr.Path
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
f = Dir(fPath & filePattern) 'Dir is faster...
Do While Len(f) > 0
colFiles.Add fPath & f
f = Dir()
Loop
Loop
Set GetMatches = colFiles
End Function
Output:
Processing: C:\Temp\SO\tester - Copy (2).docx
Processing: C:\Temp\SO\tester - Copy - Copy.docx
Processing: C:\Temp\SO\tester - Copy.docx
Processing: C:\Temp\SO\tester.docx
Processing: C:\Temp\SO\blah\tester - Copy (2).docx
Processing: C:\Temp\SO\blah\tester - Copy - Copy.docx
Processing: C:\Temp\SO\blah\tester - Copy.docx
Processing: C:\Temp\SO\blah\tester.docx
Processed 8 files

Answer 2

«I need pop-up windows as described in my original post. I'm not familiar enough with this stuff to make changes» For example:
Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String, StrFnd As String, StrRep As String
Sub Main()
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
StrFnd = InputBox("Enter finding text here:")
If StrFnd = "" Then Exit Sub
StrRep = InputBox("Enter replacing text here:")
TopLevelFolder = GetFolder
If TopLevelFolder = "" Then Exit Sub
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
End Sub
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
RecurseWriteFolderName (SubFolder)
Next
End Sub
Sub UpdateDocuments(oFolder As String)
Application.ScreenUpdating = False
Dim strInFolder As String, strFile As String, wdDoc As Document
strInFolder = oFolder
strFile = Dir(strInFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Text = StrFnd
.Replacement.Text = StrRep
.Execute Replace:=wdReplaceAll
End With
'Save and close the document
.Close SaveChanges:=True
End With
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
As coded, the macro will process .doc, .docx, and .docm files. To limit it to .docx files, change the .doc reference to .docx.