Excel VBA loop performs very slow if used on a large data set and then crashes

Question

I'm not a developer but I read a bit here and there to be able to understand some of it. This might be a simple problem that I'm facing but I can't seem to figure it out. So thank you for helping me on this!

I wrote with the help of Google a short script that is supposed to turn a CSV export into a readable format. It is supposed to do a few more things but I'm already facing performance issues just with the objective of making a few entries readable.

Here's what I have so far:

Sub MagicButton_Click()

'Find the last non-empty cell in column A
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row


'Set Variables to work with the cell content
Dim CellContent As String
Dim CellContentArr As Variant


'Set looping variables
Dim i, j As Integer
Dim FirstRow As Integer
Dim FirstCol As Integer
Dim ActiveCol As Integer
Dim itm As Variant

FirstRow = 1
FirstCol = 2

Dim x, y As String





'Loop (1) through all rows
For i = FirstRow To LastRow
    'Save cell content to string
    CellContent = ActiveSheet.Cells(i, 1).Text

        'Split string into array
        CellContentArr = Split(CellContent, "{")
        'Reset column
        ActiveCol = FirstCol

        'Loop (2) through the array
        For Each itm In CellContentArr

            'Remove quotations and other symbols
            itm = Application.WorksheetFunction.Clean(itm)
            itm = Replace(itm, """", "")

            'This is the part that creates performance issues
            'For j = 1 To Len(itm)
            '    x = Mid(itm, j, 1)
            '    If x Like "[A-Z,a-z,0-9 :.-]" Then
            '        y = y & x
            '    End If
            'Next j

            'itm = y
            'y = ""


            'Write each item in array to an individual cells within the same row
            ActiveSheet.Cells(i, ActiveCol) = itm
            ActiveCol = ActiveCol + 1

        Next itm
    Next i
End Sub

This entire script works fine when I test on ~10 rows. When using it on the entire set of 220 rows, it becomes unresponsive and eventually crashes.

In the script I have commented what causes this performance issue. I'm guessing it is because there are three loops. The third loop iterates through every char in the string to check if it is an allowed char or not and then keeps or deletes it.

What can I do to improve performance, or at least, make it so that Excel doesn't turn unresponsive?

Sidenote: It is supposed to work both on Mac & Windows. I don't know if RegEx would have a better performance to filter out the unwanted char, but I also don't know if it is possible to use that for both Mac & Windows.

Answer 1

The answers that have been given would be good adjustments to your code. However, there might be a better approach to this.

Firstly, reading a range into an array and manipulating the resultant array is markedly faster than reading cell by cell.

Secondly, if you are iterating each character in your array and checking for specific items with a curly bracket signalling a new column, then couldn't you just do it all in one iteration. It seems a little redundant to split and clean first.

All in all, your code could be as simple as this:

Dim lastCell As Range
Dim v As Variant
Dim r As Long
Dim c As Long
Dim i As Integer
Dim output() As String
Dim b() As Byte

'Read the values into an array
With ThisWorkbook.Worksheets("Sheet1")
    Set lastCell = .Cells(.Rows.Count, "A").End(xlUp)
    v = .Range(.Cells(1, "A"), lastCell).Value2
End With

ReDim output(1 To UBound(v, 1), 1 To 1)

'Loop through the array rows and characters
For r = 1 To UBound(v, 1)
    c = 1
    'Convert item to byte array - just personal preference, you could iterate a string
    b = StrConv(v(r, 1), vbFromUnicode)
    For i = 0 To UBound(b)
        Select Case b(i)
            Case 45, 46, 58, 65 To 90, 97 To 122, 48 To 57 '-, :, ., A-Z, a-z, 0-9
                output(r, c) = output(r, c) & Chr(b(i))
            Case 123 '{
                'add a column and expand output array if necessary
                If Len(output(r, c)) > 0 Then
                    c = c + 1
                    If c > UBound(output, 2) Then
                        ReDim Preserve output(1 To UBound(v, 1), 1 To c)
                    End If
                End If
            Case Else
                'skip it
        End Select
    Next
Next

'Write item to worksheet
ThisWorkbook.Worksheets("Sheet1").Cells(1, "B") _
    .Resize(UBound(output, 1), UBound(output, 2)).Value = output

Answer 2

Three things - you need to disable screenupdating and you need to declare variables in a better way. Do not do it like "Dim a,b,c,d,e as Integer", because only the last one is integer, the others are variant. Last but not least, do not use Integer in VBA, but this is not your problem here.

This should work faster:

Sub MagicButton_Click()

'Find the last non-empty cell in column A
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row


'Set Variables to work with the cell content
Dim CellContent As String
Dim CellContentArr As Variant


'Set looping variables
Dim i  As   Long
dim j as    Long
Dim FirstRow As Long
Dim FirstCol As Long
Dim ActiveCol As Long
Dim itm As Variant

FirstRow = 1
FirstCol = 2

Dim x   as string
dim y   As String

call onstart
'Loop (1) through all rows
For i = FirstRow To LastRow
    'Save cell content to string
    CellContent = ActiveSheet.Cells(i, 1).Text

        'Split string into array
        CellContentArr = Split(CellContent, "{")
        'Reset column
        ActiveCol = FirstCol

        'Loop (2) through the array
        For Each itm In CellContentArr

            'Remove quotations and other symbols
            itm = Application.WorksheetFunction.Clean(itm)
            itm = Replace(itm, """", "")

            'This is the part that creates performance issues
            'For j = 1 To Len(itm)
            '    x = Mid(itm, j, 1)
            '    If x Like "[A-Z,a-z,0-9 :.-]" Then
            '        y = y & x
            '    End If
            'Next j

            'itm = y
            'y = ""


            'Write each item in array to an individual cells within the same row
            ActiveSheet.Cells(i, ActiveCol) = itm
            ActiveCol = ActiveCol + 1

        Next itm
    Next i

    call onend

End Sub


Public Sub OnStart()

    Application.AskToUpdateLinks = False
    Application.ScreenUpdating = False
    Application.Calculation = xlAutomatic
    Application.EnableEvents = False
    Application.DisplayAlerts = False

End Sub

Public Sub OnEnd()

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False
    Application.AskToUpdateLinks = True

End Sub

Answer 3

Task List

• Copy source range into an array
• Clean array
• Copy array back to source range
• Split data into multiple columns using TextToColumns

Sub MagicButton_Click2()
    Dim arData
    Dim LastRow As Long, i As Integer
    Dim dataRange As Range
    LastRow = Range("A" & rowS.Count).End(xlUp).Row

    Set dataRange = Range(Cells(1, 1), Cells(LastRow, 1))
    arData = dataRange.value


    For i = 1 To UBound(arData)
        arData(i, 1) = AlphaNumericOnly(CStr(arData(i, 1)))
    Next

    dataRange.value = arData
    dataRange.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="{", TrailingMinusNumbers:=True
End Sub

' http://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp
Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 48 To 57, 65 To 90, 97 To 123: 'include 32 if you want to include space I added 123 to include the {
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function