Most efficient multi-find/replace solution in Excel VBA

Question

I'm looking to improve the runtime and efficiency of my VBA code that performs multiple Replace operations on an Excel Spreadsheet. I started out with the following (please forgive me for this horrendous mess):

_{Note: Some values/symbols did not show up correctly in this first piece of code
(blank values displayed in 'What:=""' and the ">" and "<" symbols displayed as normal ">" and "<" symbols, which they are not)}

Private Sub symbolCheck()
Range("A2").Select
'Selects only to the end of all the data in the file to reduce processing time
Range(Selection, Selection.SpecialCells(xlLastCell)).Select

'Proceed with removing invalid symbols
'Apostrophe/Closing Single Quote
Selection.Replace What:="", Replacement:="'", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Apostrophe
Selection.Replace What:="`", Replacement:="'", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Opening Single Quote
Selection.Replace What:="", Replacement:="'", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Double Open Quotes
Selection.Replace What:="", Replacement:="""", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Double Closing Quotes
Selection.Replace What:="", Replacement:="""", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Dash
Selection.Replace What:="", Replacement:="-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Registered Trademark (R)
Selection.Replace What:="®", Replacement:="(R)", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Trademark (TM)
Selection.Replace What:="", Replacement:="(TM)", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Degree Symbol
Selection.Replace What:="°", Replacement:=" degrees", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Multiplication/x Symbol
Selection.Replace What:="×", Replacement:="x", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Upside-Down Question Mark Symbol
Selection.Replace What:="¿", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Solid Bullet Symbol
Selection.Replace What:="", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Triple Dots Symbol
Selection.Replace What:="", Replacement:="...", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Euro Symbol
Selection.Replace What:="", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Linebreak Symbol
Selection.Replace What:="|", Replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Less Than Symbol
Selection.Replace What:="<", Replacement:="<", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Greater Than Symbol
Selection.Replace What:=">", Replacement:=">", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Half Fraction
Selection.Replace What:="½", Replacement:=" 1/2", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Three Quarter Fraction
Selection.Replace What:="¾", Replacement:=" 3/4", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'One Quarter Fraction
Selection.Replace What:="¼", Replacement:=" 1/4", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

End Sub

This code takes around 31.57 seconds to run on about 15000 row (~150 column) file.

After doing a decent amount of research and trial and error:

• I'm using the little tweaks (disabling various Excel activity) suggested here.
• I've adjusted/cleaned up my code according to the example given here, removing my extra Replace criteria that was not needed and using the With statement so I don't have to keep repetively referencing the range. However, I did not use the .SpecialCells(xlCellTypeConstants) suggestion given in this example because my code actually ran much slower than when I use UsedRange.

Leaving me with this updated version of my code:

Private Sub symbolCheck()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim r1 As Range
'Range("A2").Select
'Selects only to the end of all the data in the file to reduce processing time
'Set r1 = Range(Selection, Selection.SpecialCells(xlLastCell))
Set r1 = ActiveSheet.UsedRange
'Proceed with removing invalid symbols
With r1
'Apostrophe/Closing Single Quote
.Replace What:="’", Replacement:=Chr(39), LookAt:=xlPart
'Apostrophe
.Replace What:="`", Replacement:=Chr(39), LookAt:=xlPart
'Opening Single Quote
.Replace What:="‘", Replacement:=Chr(39), LookAt:=xlPart
'Double Open Quotes
.Replace What:="“", Replacement:="""", LookAt:=xlPart
'Double Closing Quotes
.Replace What:="”", Replacement:="""", LookAt:=xlPart
'Dash
.Replace What:="–", Replacement:="-", LookAt:=xlPart
'Registered Trademark (R)
.Replace What:="®", Replacement:="(R)", LookAt:=xlPart
'Trademark (TM)
.Replace What:="™", Replacement:="(TM)", LookAt:=xlPart
'Degree Symbol
.Replace What:="°", Replacement:=" degrees", LookAt:=xlPart
'Multiplication/x Symbol
.Replace What:="×", Replacement:="x", LookAt:=xlPart
'Upside-Down Question Mark Symbol
.Replace What:="¿", Replacement:="", LookAt:=xlPart
'Solid Bullet Symbol
.Replace What:="•", Replacement:="", LookAt:=xlPart
'Triple Dots Symbol
.Replace What:="…", Replacement:="...", LookAt:=xlPart
'Euro Symbol
.Replace What:="€", Replacement:="", LookAt:=xlPart
'Linebreak Symbol
.Replace What:="|", Replacement:=",", LookAt:=xlPart
'Less Than Symbol
.Replace What:="<", Replacement:="<", LookAt:=xlPart
'Greater Than Symbol
.Replace What:=">", Replacement:=">", LookAt:=xlPart
'Half Fraction
.Replace What:="½", Replacement:=" 1/2", LookAt:=xlPart
'Three Quarter Fraction
.Replace What:="¾", Replacement:=" 3/4", LookAt:=xlPart
'One Quarter Fraction
.Replace What:="¼", Replacement:=" 1/4", LookAt:=xlPart
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

After making those adjustments I'm still left around 26.5-27.8 seconds for the code to run on the same 15000 row (~150 column) file.

I've also come upon, but have not tried:

• I'm curious whether using a variation of Option 2 (using regEx) given here would help improve my time anymore.
• And I'm not sure whether going about this multiple find/replace action using arrays like here would be beneficial or help speed up the code anymore

Does anyone have any ideas or critique on how I can further increase the speed of this code?

Answer 1

I don't know about the performance (looks like pretty intensive work anyway), but code-wise, it can definitely improve!

You're repeating the .Replace call as many times as you have things to replace. Extract it into its own method, and separate the concerns of "knowing what to look for" and "replacing stuff".

Start with renaming r1 to a meaningful name, adding Option Explicit at the top of your module, and referencing the Microsoft Scripting Runtime library. Then do this:

Dim searchRange As Range
Set searchRange = ActiveSheet.UsedRange

Dim replacements As Dictionary
Set replacements = New Dictionary
With replacements
    .Add "’", "'"
    .Add "`", "'"
    .Add "‘", "'"
    .Add "“", """"
    .Add "”", """"
    .Add "–", "-"
    .Add "®", "(R)"
    .Add "™", "(TM)"
    .Add "°", " degrees"
    .Add "×", "x"
    .Add "¿", vbNullString
    .Add "•", vbNullString
    .Add "…", "..."
    .Add "€", vbNullString
    .Add "|", ","
    .Add "<", "<"
    .Add ">", ">"
    .Add "½", " 1/2"
    .Add "¾", " 3/4"
    .Add "¼", " 1/4"
End With

When you have a new symbol to replace, you just .Add it and its replacement to that Dictionary, and now you have a single data structure to iterate, contrary to the "dual array" suggestion you've come across - whenever you have two arrays with indices lined up and a requirement for them to "keep in sync", you're using the wrong data structure.

The benefit here isn't one of performance, it's one of maintainability and readability: instead of reading like a macro-recorder script, your code starts reading more naturally, like actual code meant to be read and maintained, not just executed.

Dim key As String
Dim value As String
For Each key In replacements.Keys
    value = replacements(key)
    If Asc(key) <> Asc(value) Then
        searchRange.Replace What:=key, Replacement:=value, LookAt:=xlPart
    Else
        Debug.Print "Extraneous key '" & key & "' could be removed from dictionary."
    End If
Next

Notice I'm checking if the key matches the value, because I noticed you have a number of superfluous replacements there, doing work for nothing.

So you are scanning something like 2,250,000 cells 20 times; it completing in 26-28 seconds means just a little more than 1 second per iteration is spent searching/replacing across 2.25 million cells: I wouldn't call that inefficient, but skipping no-op iterations that replace a value by the same value (looking at "<" and ">" in particular), and avoiding calls to Chr(), could possibly trim another 1-3 seconds from it.

Also, I wouldn't rely on UsedRange, as it tends to not always match the range that you're interested in: if that's the case, you could skip a few thousand iterations and shave off another couple of seconds by working with the actually used range. See this SO post.

Answer 2

I finally found a method that greatly reduces the time it takes for my piece of code to run. Building off of a method I stumbled upon here I reduced the runtime of this Sub Routine all the way down to 5-7 seconds for 15000 rows (140 columns).

First, I dumped the UsedRange into a Variable Array (since cycling through an Array is a lot quicker than looping through actual cells), then I test each slot to first make sure it's not empty (this saved me loads of time), then if it wasn't empty I tested each slot for each value I was looking to replace by using the Instr() function. This way I can save time by only performing each Substitute only if the value was found in that slot.

Sub NewAndImprovedSymbolCheck()
Dim MyArray As Variant
MyArray = ActiveSheet.UsedRange
starttime = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For i = LBound(MyArray) To UBound(MyArray)
    For j = LBound(MyArray, 2) To UBound(MyArray, 2)
        If MyArray(i, j) <> "" Then
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", Chr(39))
                'MyArray(i, j).Replace What:="", Replacement:=Chr(39), LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "`") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "`", Chr(39))
                'MyArray(i, j).Replace What:="`", Replacement:=Chr(39), LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", Chr(39))
                'MyArray(i, j).Replace What:="", Replacement:=Chr(39), LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", """")
                'MyArray(i, j).Replace What:="", Replacement:="""", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", """")
                'MyArray(i, j).Replace What:="", Replacement:="""", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", "-")
                'MyArray(i, j).Replace What:="", Replacement:="-", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "®") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "®", "(R)")
                'MyArray(i, j).Replace What:="®", Replacement:="(R)", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", "(TM)")
                'MyArray(i, j).Replace What:="", Replacement:="(TM)", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "°") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "°", " degrees")
                'MyArray(i, j).Replace What:="°", Replacement:=" degrees", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "×") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "×", "x")
                'MyArray(i, j).Replace What:="×", Replacement:="x", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "¿") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "¿", "")
                'MyArray(i, j).Replace What:="¿", Replacement:="", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", "")
                'MyArray(i, j).Replace What:="", Replacement:="", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", "...")
                'MyArray(i, j).Replace What:="", Replacement:="...", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "", "")
                'MyArray(i, j).Replace What:="", Replacement:="", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "|") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "|", ",")
                'MyArray(i, j).Replace What:="|", Replacement:=",", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "<") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "<", "<")
                'MyArray(i, j).Replace What:="<", Replacement:="<", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), ">") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), ">", ">")
                'MyArray(i, j).Replace What:=">", Replacement:=">", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "½") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "½", " 1/2")
                'MyArray(i, j).Replace What:="½", Replacement:=" 1/2", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "¾") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "¾", " 3/4")
                'MyArray(i, j).Replace What:="¾", Replacement:=" 3/4", LookAt:=xlPart
            End If
            If InStr(1, MyArray(i, j), "¼") > 0 Then
                MyArray(i, j) = WorksheetFunction.Substitute(MyArray(i, j), "¼", " 1/4")
                'MyArray(i, j).Replace What:="¼", Replacement:=" 1/4", LookAt:=xlPart
            End If
        End If
    Next j
Next i
ActiveSheet.UsedRange = MyArray

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox Timer - starttime
End Sub

Answer 3

I've tested out both the regex and array looping methods that I provided in links above and they indeed did not improve the speed of the code (regex was actually much slower).

I've even looked into crazy ideas like dumping the entire spreadsheet into as few cells as possible just while performing the replaces (and along the way I found out some interesting limitations of a single cell that I hadn't previously known)

I've also tested out @Mat's Mug's suggestion of using a scripting dictionary and though, yes, it is tidier it also was slightly slower than my second piece of code above. So, if ANYONE has any other ideas to try I'm all ears.