Mass Find & Replace including subfolders-CodePudding

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!

CodePudding user response：

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

CodePudding user response：

«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, strOutFold As String, strFile As String, wdDoc As Document
strInFolder = oFolder
strFile = Dir(strInFolder & "\*.doc", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFolder & "\Output\"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
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 two .doc references to .docx.