8
\$\begingroup\$

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?

\$\endgroup\$
0

3 Answers 3

6
\$\begingroup\$

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.

\$\endgroup\$
1
  • 1
    \$\begingroup\$ Great piece of advice @Mat's Mug, thank you. Using a dictionary for this does appear to be much more readable and maintainable. Though, I should've mentioned that those two values you mentioned ("<" and ">") were originally in some other format, but changed when I pasted them here for some reason. As for using Chr() I had no choice due to my file simply wiping out those values instead of replacing them with the unicode apostrophe. I will certainly consider this approach, but I am still holding out some hope that someone out there has an idea that will help speed things up a bit somehow. \$\endgroup\$ Feb 16, 2016 at 21:38
1
\$\begingroup\$

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
\$\endgroup\$
6
  • 1
    \$\begingroup\$ Indeed, the single slowest thing to do is accessing cells; good approach, but it still reads as macro-recorder code, I'd strongly recommend taking whatever performance hit comes with greater readability and maintainability. \$\endgroup\$ Feb 19, 2016 at 14:18
  • \$\begingroup\$ I understand that it reads as macro-recorder, but my mission was to simply decrease the processing time of the code (as I stated in my question). Readability is not an issue for me because it'll be me alone maintaining this code, so as long as I can understand it (which I do), then I consider that mission (increasing speed) accomplished. \$\endgroup\$ Feb 19, 2016 at 14:22
  • 1
    \$\begingroup\$ Not my downvote (I actually upvoted this answer), however I'm not buying the "I'm the only maintainer" argument. Code should be written as if the next person to maintain it is a dangerous axe murderer that knows where you live =) \$\endgroup\$ Feb 19, 2016 at 14:24
  • \$\begingroup\$ If you're after speed improvements, don't use Worksheet functions on in memory arrays, VBA has it's own replace function - use that. Additionally, you could combine the dictionary approach of @Mat'sMug with your code above for much better maintainability \$\endgroup\$
    – SWa
    Feb 25, 2016 at 8:31
  • \$\begingroup\$ There's a reason I didn't use the replace function. It has a character limitation and many of the values I check exceed that limit. \$\endgroup\$ Feb 25, 2016 at 12:42
0
\$\begingroup\$

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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.