Multiple Find and Replace in Multiple Files - Faster to use Array or Dictionary over Replace?

[rdetreville]

Hello,

I have a few hundred files with incorrect staff names on several worksheets, all located in sub-folders. I put together a macro that will open each Excel file, look down a list of incorrect names in the "fixnames.xlsm" workbook that houses the macro (Column 1) and replaces them with the corrected name in Column 2.

It seems to be working (though it sometimes doesn't seem to look at all worksheets) but is EXTREMELY SLOW. It will take hours to run this macro. I've already set to manual calculation and have disabled screen updating.

Is there some sort of array or dictionary function I could use to make this more efficient? Would it be faster to hard code the corrections into the macro instead of have them be retrieved from a spreadsheet? Right now it's Replacing by Cell - which is likely why it is so slow. Is there a way to have it perform this task faster? I'm desperate - have been searching for two days and no one has helped me. I have a meeting in a few hours and I'm expected to have this finished.

Thanks,

Richard

Sub test()

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
    Dim MyFolder As String
    Dim wkbOpen As Workbook
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim CalcMode As Long
    
       
             Dim rList As Range, cell As Range

 Dim wkboook As Workbook
 Dim sht As Worksheet
 

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
            
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select tracker folder..."
        If .Show Then
            MyFolder = .SelectedItems(1)
            If Not Right(MyFolder, 1) = "\" Then
                MyFolder = MyFolder & "\"
            End If
        Else
            'No folder selected
        End If
    End With
    
                  
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(MyFolder)
    Set wkb = ActiveWorkbook
    Set wks = ActiveSheet
     Set wkboook = Workbooks("fixnames.xlsm")
    With wkboook.Sheets(1)
        Set rList = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    For Each objSubFolder In objFolder.SubFolders
        For Each objFile In objSubFolder.Files
            Set wkbOpen = Workbooks.Open(objFile.Path)
        For Each sht In ActiveWorkbook.Worksheets
        For Each cell In rList
        ActiveSheet.Cells.Replace What:=cell.Value, _
                                  Replacement:=cell.Offset(0, 1).Value, _
                                  LookAt:=xlWhole, _
                                  MatchCase:=False
                                  
    Next cell
    Next sht
           
            wkbOpen.Close savechanges:=True
        Next objFile
    Next objSubFolder
    
    With Application
        .Calculation = CalcMode
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    MsgBox "Completed...", vbInformation
    
End Sub