Update existing find and replace macro (folder level) to also work on subfolders and would like popu-CodePudding

I have a find and replace macro that updates rtf files at the folder level. I'd like this macro to also be able to update rtf files in subfolders as well. Additionally, the current macro dialog box requires user to select the folder that contains the rtf files each time the macro is run. I'd prefer to have the option to enter the location of the parent folder either directly in the dialog box (my preference) or hard code the parent folder directory into the macro. Any help you can offer would be greatly appreciated as I am not very good with VBA.

Here is the full macro:


Sub UpdateBODY()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, wdDoc As Document, Rng As Range
    Dim Sctn As Section, HdFt As HeaderFooter, Fnd As String, Rep As String
    Dim protection As Long
    Fnd = "ACCOUNTING": Rep = "FINANCE"
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.rtf", vbNormal)
    While strFile <> ""
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=True)
        With wdDoc
            'record current protection type and unprotect if necessary
            protection = .ProtectionType
            If protection <> wdNoProtection Then .Protect wdNoProtection
            'Process everything except headers & footers
            For Each Rng In .StoryRanges
                Select Case Rng.StoryType
                    Case wdPrimaryFooterStory, wdFirstPageFooterStory, wdEvenPagesFooterStory, _
                        wdPrimaryHeaderStory, wdFirstPageHeaderStory, wdEvenPagesHeaderStory
                    Case Else
                        Call RngFndRep(Rng, Fnd, Rep)
                End Select
            Next
            'reapply protection if necessary
            If protection <> wdNoProtection Then .Protect protection
            .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

Sub RngFndRep(Rng As Range, Fnd As String, Rep As String)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Format = False
  .Forward = True
  .Wrap = wdFindContinue
  .Text = Fnd
  .Replacement.Text = Rep
  .MatchCase = True
  .MatchAllWordForms = False
  .MatchWholeWord = False
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With
End Sub

Attempted to run this macro on a parent folder that has appx 50 child folders and each child folder has approximately 100 rtf files. I want to be able to select the single parent folder, run the macro, and macro runs on all rtf files within the child folder.

CodePudding user response：

The full code:

Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String
 
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
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
Application.ScreenUpdating = True
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
 
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

Sub UpdateDocuments(oFolder As String)
Dim strFile As String, wdDoc As Document, Rng As Range
Dim Sctn As Section, HdFt As HeaderFooter, Prot As Long
Const Fnd As String = "ACCOUNTING": Const Rep As String = "FINANCE"
strFile = Dir(oFolder & "\*.rtf", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=oFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    'record current protection type and unprotect if necessary
    Prot = .ProtectionType
    If Prot <> wdNoProtection Then .Protect wdNoProtection
    'Process everything except headers & footers
    For Each Rng In .StoryRanges
      Select Case Rng.StoryType
        Case wdPrimaryFooterStory, wdFirstPageFooterStory, wdEvenPagesFooterStory, _
          wdPrimaryHeaderStory, wdFirstPageHeaderStory, wdEvenPagesHeaderStory
        Case Else
          Call RngFndRep(Rng, Fnd, Rep)
      End Select
    Next
    'reapply protection if necessary
    If Prot <> wdNoProtection Then .Protect Prot
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
End Sub

Sub RngFndRep(Rng As Range, Fnd As String, Rep As String)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Format = False
  .Forward = True
  .Wrap = wdFindContinue
  .Text = Fnd
  .Replacement.Text = Rep
  .MatchCase = True
  .MatchAllWordForms = False
  .MatchWholeWord = False
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With
End Sub