Find Replace cell content in Multiple Workbooks in Multiple subfolders

[PressEscape]

I have bill of material workbooks in multiple sub folders that I wish to replace cell content when something is revised
e.g "Flow Restrictor 1.0mm orifice" to become "Flow Restrictor 2.0mm orifice"

I've managed to get some code to loop through the top folder shown below.
Can anyone help with the code to get it to loop through subfolders as well please.

Sub ReplaceInFolder()
    Dim strPath As String
    Dim strFile As String
    Dim wbk As Workbook
    Dim wsh As Worksheet
    Dim strFind As String
    Dim strReplace As String
    Dim i As Long
 
    
    'strFind = InputBox("Enter text to find")
    strFind = ("Flow Restrictor 1.0mm orifice")
    If strFind = "" Then
        MsgBox "No find text found!", vbExclamation
        Exit Sub
    End If
    
    strReplace = ("Flow Restrictor 2.0mm orifice")
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
                strPath = .SelectedItems(1)
            Else
                MsgBox "No folder selected!", vbExclamation
            Exit Sub
        End If
    End With
 
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    
    Application.ScreenUpdating = False
    strFile = Dir(strPath & "*.xlsx*")
  
    Do While strFile <> ""
        Set wbk = Workbooks.Open(fileName:=strPath & strFile, AddToMRU:=False)
        For Each wsh In wbk.Worksheets
            wsh.Cells.Replace What:=strFind, Replacement:=strReplace, _
                LookAt:=xlWhole, MatchCase:=False
             
                Next wsh
        wbk.Close SaveChanges:=True
        strFile = Dir
    
    Loop
        
        MsgBox "File run OK", vbExclamation
        
    Application.ScreenUpdating = True

End Sub

 

[Artik]

Dir has problems with recursive calls. In addition, it has problems with some unusual characters (I'm not talking about reserved characters in names)
I developed at one time a procedure that returns an array of found files in the indicated folder (optionally also in subfolders).
The code after changes:

Sub ReplaceInFolder()
    Dim strPath As String
    Dim strFile As String
    Dim wbk As Workbook
    Dim wsh As Worksheet
    Dim strFind As String
    Dim strReplace As String
    Dim i As Long
    Dim vArrFiles As Variant


    'strFind = InputBox("Enter text to find")
    strFind = ("Flow Restrictor 1.0mm orifice")
    strReplace = ("Flow Restrictor 2.0mm orifice")

    If Len(strFind) = 0 Then
        MsgBox "No find text found!", vbExclamation
        Exit Sub
    End If

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            strPath = .SelectedItems(1)
        Else
            MsgBox "No folder selected!", vbExclamation
            Exit Sub
        End If
    End With

    Call FileList(strPath, vArrFiles, "[!~]*.xlsx", True)

    If IsEmpty(vArrFiles) Then
        MsgBox "No files found", vbExclamation, "File List"
        Exit Sub
    End If

    Application.ScreenUpdating = False

    For i = LBound(vArrFiles) To UBound(vArrFiles)
        Set wbk = Workbooks.Open(Filename:=vArrFiles(i), AddToMRU:=False)
        For Each wsh In wbk.Worksheets
            wsh.Cells.Replace What:=strFind, Replacement:=strReplace, _
                              LookAt:=xlWhole, MatchCase:=False

        Next wsh
        wbk.Close SaveChanges:=True
    Next i

    MsgBox "File run OK", vbInformation

    Application.ScreenUpdating = True

End Sub


Sub FileList(ByVal sFolder As String, ByRef vArrFiles As Variant, _
              Optional sFilter As String, Optional vSubFolders As Variant)

'---------------------------------------------------------------------------------------
' Procedure : FileList
' DateTime  : 08.12.2013
' Author    : Artik
' Purpose   : The procedure that lists the names of files (full reference) in the specified folder.
'             The procedure works recursively.
'
' sFolder -   Required; indicated folder
' varrFiles - Required; variable of type Variant, to which an array of found files will be passed
' sFilter -   Optional; pattern by which files are searched for
'             if not specified - all files
'             Pattern examples: "*.xls*" - Excel files
'                               "*Q#*.xls*" - Excel files containing the quarter number in the name
'                               "Report*.*" - all files whose name begins with Report...
'                               "[!~]*.xls*" - Excel files, without temporary files
' vSubFolders - Optional;
'               if not specified - and the folder contains subfolders,
'                                  you will be asked whether to include subfolders in the search
'               True - when there are subfoders, absolutely search them
'               False - when there are subfolders, absolutely DO NOT search them
'---------------------------------------------------------------------------------------
'

    Dim FSO As Object
    Dim fsoFolder As Object
    Dim fsoSubFolders As Object
    Dim fsoSubFolder As Object
    Dim fsoFile As Object
    Dim i As Long


    Set FSO = CreateObject("Scripting.FileSystemObject")

    If FSO.FolderExists(sFolder) Then
        Set fsoFolder = FSO.GetFolder(sFolder)
        Set fsoSubFolders = fsoFolder.SubFolders

        If fsoSubFolders.Count > 0 Then

            If IsMissing(vSubFolders) Then
                If MsgBox("Whether to include subfolders?", _
                          vbQuestion + vbYesNo, _
                          "File List") = vbYes Then
                    vSubFolders = True
                Else
                    vSubFolders = False
                End If
            End If

        Else
            vSubFolders = False

        End If    'fsoSubFolders.Count > 0


        If Len(sFilter) = 0 Then sFilter = "*.*"


        For Each fsoFile In fsoFolder.Files
            Application.StatusBar = "Searching the folder: " & fsoFolder.Path

            If UCase(fsoFile.Name) Like UCase(sFilter) Then
                If IsEmpty(vArrFiles) Then
                    ReDim vArrFiles(1 To 1)
                End If

                i = UBound(vArrFiles)

                If IsEmpty(vArrFiles(i)) Then
                    i = i - 1
                End If

                i = i + 1

                ReDim Preserve vArrFiles(1 To i)

                vArrFiles(i) = fsoFile.Path

            End If    'UCase(fsoFile.Name) Like UCase(sFilter)

        Next fsoFile


        If vSubFolders Then
            For Each fsoSubFolder In fsoSubFolders
                Call FileList(fsoSubFolder.Path, vArrFiles, sFilter, True)
            Next fsoSubFolder
        End If    'vSubFolders = True

    End If    'FSO.FolderExists(sFolder) = True

    Set fsoSubFolders = Nothing
    Set fsoFolder = Nothing
    Set FSO = Nothing

    Application.StatusBar = False
End Sub

Artik

 

[PressEscape]

This works as it says on the tin
This has opened a raft of possibilities for running updates on our B.O.Ms
Thanks Artik
If any other options are out there please post

Cheers
PressDelete

 

[Mike_AL]

This was super helpful, thank you so much! I took your (Artik's) code and combined it with another piece of code from here to do a find and replace where the find and replace values are listed in a table. This allows for finding and replacing multiple values at the same time. Worked for me to replace faulty data entries in 1300+ excel files. Here's the code if someone needs it (VBA newby, so go easy on me )

Option Explicit

Sub ReplaceInAllSubFolders_NEW()

'Sources: https://answers.microsoft.com/en-us/msoffice/forum/all/find-and-replace-multiple-values-over-multiple/dec24a98-33e7-4934-95de-056bf577e9df and https://www.mrexcel.com/board/threads/find-replace-cell-content-in-multiple-workbooks-in-multiple-subfolders.1258325/#post-6180596


    ' ************** Change the constants as needed ***************
    Const ListSheet = "List" ' sheet with the find and replace text
    Const FindCol = "A"      ' column with the find text
    Const ReplaceCol = "B"   ' column with the replacement text
    Const FirstRow = 2       ' first row with find/replacement text
    ' *************************************************************
    
Dim wshList As Worksheet
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Dim myFolder As Object
Dim strPath As String
Dim wbk As Workbook
Dim wsh As Worksheet
Dim strFind As String
Dim strReplace As String
Dim r As Long
Dim LastRow As Long


    Set myFolder = Application.FileDialog(msoFileDialogFolderPicker)
    With myFolder
        .Title = "Select root folder to process..."
        .AllowMultiSelect = False
        If .Show <> -1 Then
            Exit Sub
        End If
        strPath = .SelectedItems(1) & "\"
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder(strPath)
    Application.ScreenUpdating = False
    
     Set wshList = ThisWorkbook.Worksheets(ListSheet)
    ' Determine the last used row in the column with the find text
    LastRow = wshList.Cells(wshList.Rows.Count, FindCol).End(xlUp).Row
    
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1 'de-queue
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder 'en-queue
        Next oSubfolder
        For Each oFile In oFolder.Files
            Set wbk = Workbooks.Open(oFile)
            For Each wsh In wbk.Worksheets
                For r = FirstRow To LastRow
                strFind = wshList.Cells(r, FindCol).Value
                strReplace = wshList.Cells(r, ReplaceCol).Value
                ' Replace
                wsh.Cells.Replace What:=strFind, Replacement:=strReplace, _
                    LookAt:=xlWhole, MatchCase:=False
            Next r
            Next wsh
            wbk.Close SaveChanges:=True
        Next oFile
    Loop
    Application.ScreenUpdating = True
    MsgBox "All Excel Files processed", vbInformation
End Sub