CODEWITHSUNDEEP
excelvba
ljpg94
ljpg94

Reputation: 13

Suggestions to speed up/improve this VBA script?

Any suggestions or tips to make this run better? I have used it on smaller data sets (100-1000 rows) and it works perfectly. Trying to run it on a data set of about 100,000 rows and it results in unresponsiveness while running and me having to force quit excel. 

    Sub CombineSchARecords()

        Dim myRow As Long

    'Row data starts
        myRow = 2

        Application.ScreenUpdating = False

    'Loop until out of data
        Do Until Cells(myRow, "A") = ""

    'Check to see if next row is for same filing number
        If Cells(myRow, "A") = Cells(myRow + 1, "A") Then

    'Add data to correct column
        Cells(myRow, "B") = Cells(myRow, "B") & ", " & Cells(myRow + 1, "B") 'SchA-3
        Cells(myRow, "C") = Cells(myRow, "C") & ", " & Cells(myRow + 1, "C") 'Schedule
        Cells(myRow, "D") = Cells(myRow, "D") & " | " & Cells(myRow + 1, "D") 'Full Legal Name
        Cells(myRow, "E") = Cells(myRow, "E") & ", " & Cells(myRow + 1, "E") 'DE/FE/I
        Cells(myRow, "F") = Cells(myRow, "F") & ", " & Cells(myRow + 1, "F") 'Entity in Which
        Cells(myRow, "G") = Cells(myRow, "G") & ", " & Cells(myRow + 1, "G") 'Title or Status
        Cells(myRow, "H") = Cells(myRow, "H") & ", " & Cells(myRow + 1, "H") 'Status Aquired
        Cells(myRow, "I") = Cells(myRow, "I") & ", " & Cells(myRow + 1, "I") 'Ownership Code
        Cells(myRow, "J") = Cells(myRow, "J") & ", " & Cells(myRow + 1, "J") 'Control Person
        Cells(myRow, "K") = Cells(myRow, "K") & ", " & Cells(myRow + 1, "K") 'PR
        Cells(myRow, "L") = Cells(myRow, "L") & ", " & Cells(myRow + 1, "L") 'OwnerID

    'Then delete row
        Rows(myRow + 1).Delete
            Else
        myRow = myRow + 1 'Move down one row if no match

            End If

Loop

Application.ScreenUpdating = True

End Sub

Thanks!

Upvotes: 1

Views: 56

Answers (2)

Kwan Wan Sing
Kwan Wan Sing

Reputation: 26

Besides of the use VBA array to define your variable, you may use below code to speedup your script as well.

Application.Calculation = xlManual
'Your code between this
Application.Calculation = xlAutomatic

Upvotes: 0

John Coleman
John Coleman

Reputation: 51998

The standard way to get a good speedup is to in one statement read everything into one big VBA array, process that array in VBA and then put the result back into the spreadsheet in another statement. Two lines of code which touch the spreadsheet, rather than 100,000+ spreadsheet read/writes in a loop

In terms of your problem this would mean something like:

Sub CombineSchARecords()
    Dim n As Long, i As Long, j As Long
    Dim numRecords As Long
    Dim Values As Variant, Processed As Variant

    n = Cells(Rows.Count, 1).End(xlUp).Row
    Values = Range(Cells(2, "A"), Cells(n, "K")).Value
    ReDim Processed(1 To n - 1, 1 To 11)

    'initialize first row of Processed
    For j = 1 To 11
        Processed(1, j) = Values(1, j)
    Next j
    numRecords = 1

    'main loop

    For i = 2 To n - 1
        If Values(i, 1) = Processed(numRecords, 1) Then
            For j = 2 To 11
                Processed(numRecords, j) = Processed(numRecords, j) & IIf(j = 4, " | ", ", ") & Values(i, j)
            Next j
        Else 'start processing a new record
            numRecords = numRecords + 1
            For j = 1 To 11
                Processed(numRecords, j) = Values(i, j)
            Next j
        End If
    Next i

    'redim Values and copy records over

    ReDim Values(1 To numRecords, 1 To 11)
    For i = 1 To numRecords
        For j = 1 To 11
            Values(i, j) = Processed(i, j)
        Next j
    Next i

    'finally:
    Range(Cells(2, "A"), Cells(n, "K")).ClearContents
    Range(Cells(2, "A"), Cells(numRecords + 1, "K")).Value = Values

End Sub

Upvotes: 1

Related Questions