Speed up slow macro loop

[jomili]

The macro below does two things: it concatenates the values in Column E, and adds the values in column J, for any duplicates in column B . The sheet it works on has 2246 lines, so the code should operate quickly. However, it takes a little under three minutes to complete (2:58). I'd appreciate some help in speeding it up.

Sub CleanUp()
     
    Dim MainRow As Long
    Dim AuxRow As Long
    Dim MatchNum As Long
    Dim KeyCol As Long
    Dim t As Date
    Dim LastRow As Long
    
    t = Now()
    
    Application.ScreenUpdating = False
    MainRow = 2
    KeyCol = 2
    MatchNum = 0
    'Determine bottom of our range (in D)
    LastRow = Range("D" & Rows.Count).End(xlUp).Row

With ActiveSheet.Range("A1:Z" & LastRow)
    Do While Cells(MainRow, KeyCol) <> ""
        AuxRow = MainRow + 1
        Do While Cells(AuxRow, KeyCol) <> ""
            If Cells(MainRow, KeyCol) = Cells(AuxRow, KeyCol) Then
                MatchNum = MatchNum + 1
                'Combine the Line Descriptions
                Cells(MainRow, 6).Value = Cells(MainRow, 6).Value & "_ Next Item: " & Cells(AuxRow, 6).Value
                Cells(MainRow, 10).Value = CLng(Cells(MainRow, 10).Value) + CLng(Cells(AuxRow, 10).Value)
                
                Rows(AuxRow).Delete
                AuxRow = AuxRow - 1
            End If
            AuxRow = AuxRow + 1
        Loop
        MainRow = MainRow + 1
        MatchNum = 0
    Loop
End With
    Application.ScreenUpdating = True
    MsgBox Format(Now() - t, "hh:mm:ss")
End Sub

[Bob Phillips]

Post the workbook.

[nilem]

not the fastest option, but you can try

Sub CleanUp2()
Dim MainRow As Long
Dim AuxRow As Long
Dim KeyCol As Long: KeyCol = 2
Dim arr, rDel As Range
Dim t As Single: t = Timer
Application.ScreenUpdating = False
arr = Range("A1:J" & Cells(Rows.Count, "D").End(xlUp).Row).Value

For MainRow = 2 To UBound(arr)
    For AuxRow = MainRow + 1 To UBound(arr)
        If arr(MainRow, KeyCol) = arr(AuxRow, KeyCol) Then
            Cells(MainRow, 6).Value = Cells(MainRow, 6).Value & "_ Next Item: " & arr(AuxRow, 6)
            Cells(MainRow, 10).Value = CLng(Cells(MainRow, 10).Value) + CLng(arr(AuxRow, 10))
            If rDel Is Nothing Then Set rDel = Cells(AuxRow, 2) Else Set rDel = Union(rDel, Cells(AuxRow, 2))
        End If
    Next AuxRow
Next MainRow
If Not rDel Is Nothing Then rDel.EntireRow.Delete

Application.ScreenUpdating = True
MsgBox Format(Timer - t, "00.00")
End Sub

[jomili]

Bob,
I've attached the workbook.

Nilem,
I got an Overflow error at this line:

 Cells(MainRow, 10).Value = CLng(Cells(MainRow, 10).Value) + CLng(arr(AuxRow, 10))

[wallyeye]

It looks like you are appending quantities and adding dates, that doesn't sound right.

Can you give a text description of what you are trying to do, without indicating the columns?

Also, generically, interacting between VB and the Excel GUI is very slow, I would recommend loading the data into an array, doing your operations there, then pasting the results back to Excel all at once. You could have an array to hold your WPR number, Quantities and Due Dates, calculate and adjust as necessary, paste the Quantity and Due Date arrays back, then delete the extra rows. In your calculate section, you could index sort based on WPR number, which would speed up your searches considerably.

Reply on my first two questions, I'll see what I can do.

[jomili]

Sure, here you go:

for any duplicates in WPR_Number I want to A: Concatnenate the line descriptions and B) add the Total costs (sorry, I said J earlier, and meant I), then delete the other duplicate rows. So, in the end, I shouldn't have ANY duplicate WPR_Numbers, but the line description column should have ALL of the line descriptions for that WPR in one cell, and the Total Cost should be the sum of the individual line items for that WPR.

I'm not that conversant with Arrays, hence my problem today. Any help is greatly appreciated.

[nilem]

intermediate option

Sub CleanUp3()
Dim x, i&, k&
Dim tm!: tm = Timer
Application.ScreenUpdating = False
x = Range("A1:J" & Cells(Rows.Count, "D").End(xlUp).Row).Value

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If .Exists(x(i, 2)) Then
            k = .Item(x(i, 2))
            Cells(k, 6).Value = Cells(k, 6).Value & "_ Next Item: " & x(i, 6)
            Cells(k, 9).Value = Val(Cells(k, 9).Value) + Val(x(i, 9))
            Cells(i, 9).Value = "zzzz"
        Else
            .Item(x(i, 2)) = i
        End If
    Next i
End With

With Range("A1").CurrentRegion
    .AutoFilter Field:=9, Criteria1:="zzzz"
    .Offset(1).EntireRow.Delete
    .AutoFilter
End With
Application.ScreenUpdating = True
MsgBox Format(Timer - tm, "0.00")
End Sub

edited
should be

Cells(k, 5).Value = Cells(k, 5).Value & "_ Next Item: " & x(i, 5)

instead of

Cells(k, 6).Value = Cells(k, 6).Value & "_ Next Item: " & x(i, 6)

[jomili]

Nilem,
I owe you an apology: My original code made use of an extra column which moved all my columns over by 1. I tried your code on my original data, minus that column, which is why I got the overflow on your code. Adjusting from columns 6 and 10 to 5 and 9, your code works flawlessly, in 104 seconds. Still slower than I'd like, but much faster than my original code.

[nilem]

or

Sub CleanUpLast()
Dim x, y(), i&, j&, k&, u&, ubx&
Dim tm!: tm = Timer
Application.ScreenUpdating = False
x = Range("A1:Z" & Cells(Rows.Count, "D").End(xlUp).Row).Value
ubx = UBound(x, 2)
ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If .Exists(x(i, 2)) Then
            k = .Item(x(i, 2))
            y(k, 5) = y(k, 5) & "_ Next Item: " & x(i, 5)
            y(k, 9) = Val(y(k, 9)) + Val(x(i, 9))
        Else
            j = j + 1: .Item(x(i, 2)) = j
            For u = 1 To ubx
                y(j, u) = x(i, u)
            Next
        End If
    Next i
End With

Range("A1").CurrentRegion.ClearContents
Range("A1:Z1").Resize(j).Value = y()

Application.ScreenUpdating = True
MsgBox Format(Timer - tm, "0.00")
End Sub

[jomili]

Holy Smokes, Nilem! Your last code just ran in .38 minutes! That's pretty fast. I'm testing it now with my main data and will let you know the results when completed. Thank You!

[jomili]

Nilem,

Your code checks out. It runs without a hitch, and it's very fast! Would you like to help me work on my car next?

Thanks so much. I couldn't have done it without you.

[wallyeye]

You can try this, it seems to run a bit faster:

Public Sub CondenseFile()

    Dim wksCurr         As Excel.Worksheet

    Dim arrWPR          As Variant
    Dim arrDesc         As Variant
    Dim arrTotal        As Variant

    Dim arrIndex()      As Long
    Dim arrDupes()      As Integer
    Dim arrPasteDesc()  As Variant
    Dim arrPasteTotal() As Variant

    Dim lngLastRow      As Long
    Dim lngCurrRow      As Long
    Dim lngNextRow      As Long
    Dim lngStartRow     As Long
    Dim strRange        As String
    Dim intCalculate    As Integer

    Const colWPR        As Integer = 2
    Const colDesc       As Integer = 5
    Const colTotal      As Integer = 9
    Const intStep       As Integer = 2500

    Debug.Print Timer
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    intCalculate = Application.Calculation
    Application.Calculation = xlCalculationManual

    Set wksCurr = Worksheets("Sheet1")
    On Error Resume Next
    lngLastRow = wksCurr.Columns(colWPR).Find(What:="*", After:=Cells(1, colWPR), _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
        LookIn:=xlFormulas, LookAt:=xlPart).Row
    If Err = 9 Then
        lngLastRow = 0
    End If
    On Error GoTo 0
    If lngLastRow > 1 Then
        arrWPR = wksCurr.Cells(2, colWPR).Resize(lngLastRow - 1, 1)
        arrDesc = wksCurr.Cells(2, colDesc).Resize(lngLastRow - 1, 1)
        arrTotal = wksCurr.Cells(2, colTotal).Resize(lngLastRow - 1, 1)
        ReDim arrDupes(LBound(arrWPR) To UBound(arrWPR))
        ReDim arrIndex(LBound(arrWPR) To UBound(arrWPR))
        Call QuickSortIndex2(arrWPR, arrIndex)
        For lngCurrRow = LBound(arrWPR) To UBound(arrWPR) - 1
            If arrDupes(arrIndex(lngCurrRow)) <> 1 Then
                For lngNextRow = lngCurrRow + 1 To UBound(arrWPR)
                    If arrWPR(arrIndex(lngNextRow), 1) = arrWPR(arrIndex(lngCurrRow), 1) Then
                        arrDesc(arrIndex(lngCurrRow), 1) = arrDesc(arrIndex(lngCurrRow), 1) _
                            & "_ Next Item: " & arrDesc(arrIndex(lngNextRow), 1)
                        arrTotal(arrIndex(lngCurrRow), 1) = CDbl(arrTotal(arrIndex(lngCurrRow), 1)) _
                            + CDbl(arrTotal(arrIndex(lngNextRow), 1))
                        arrDupes(arrIndex(lngNextRow)) = 1
                    Else
                        Exit For
                    End If
                Next lngNextRow
            End If
        Next lngCurrRow
    End If

    wksCurr.Cells(2, colTotal).Resize(lngLastRow - 1, 1) = arrTotal
    wksCurr.Cells(2, colDesc).Resize(lngLastRow - 1, 1) = arrDesc

    For lngCurrRow = UBound(arrWPR) To LBound(arrWPR) Step -1
        If arrDupes(lngCurrRow) = 1 Then
            strRange = strRange & CStr(lngCurrRow + 1) & ":" & CStr(lngCurrRow + 1) & ","
            If Len(strRange) > 240 Then
                strRange = Left(strRange, Len(strRange) - 1)
                wksCurr.Range(strRange).Delete xlShiftUp
                strRange = ""
            End If
        End If
    Next lngCurrRow
    If strRange > "" Then
        strRange = Left(strRange, Len(strRange) - 1)
        wksCurr.Range(strRange).Delete xlShiftUp
    End If

    Set wksCurr = Nothing

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = intCalculate
    Debug.Print Timer

End Sub

With a QuickSort routine:

Public Function QuickSortIndex2(ByRef pvarArray As Variant, ByRef arrIndex As Variant, _
    Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)

    Dim lngFirst        As Long
    Dim lngLast         As Long
    Dim lngCurr         As Long
    Dim varMid          As Variant
    Dim varSwap         As Variant

    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
        For lngCurr = plngLeft To plngRight
            arrIndex(lngCurr) = lngCurr
        Next lngCurr
    End If

    lngFirst = plngLeft
    lngLast = plngRight
    varMid = pvarArray(arrIndex(Int((plngLeft + plngRight - 1) \ 2)), 1)
    Do
        Do While pvarArray(arrIndex(lngFirst), 1) < varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        Do While varMid < pvarArray(arrIndex(lngLast), 1) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        If lngFirst <= lngLast Then
            lngCurr = arrIndex(lngLast)
            arrIndex(lngLast) = arrIndex(lngFirst)
            arrIndex(lngFirst) = lngCurr
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If plngLeft < lngLast Then QuickSortIndex2 pvarArray, arrIndex, plngLeft, lngLast
    If lngFirst < plngRight Then QuickSortIndex2 pvarArray, arrIndex, lngFirst, plngRight

End Function

You will want to edit the set command to point to your real worksheet, and I set up some constants to point to the column numbers that you might want to edit as well: colWPR, colDesc, colTotal.

It essentially does what I was describing earlier: Load the WPR numbers, descriptions and totals into arrays, index sort by WPR number, loop through the sorted WPR's looking for duplicates that haven't been totaled already. For duplicate entries, append to the description and accumulate the totals and set a flag on the record indicating that it has been used as a duplicate. Once all the WPR numbers have been looked at, move the entire description totals array to the spreadsheet. Then loop backwards through the array, building a string of ranges to delete and deleting them. The range object has a limit of 255 characters, so I put a length check and reset in.

On my machine, it took less than two seconds...

[jomili]

Walleye,

Sorry to tell you, but Nilem's code is faster. I didn't get a chance to test both yesterday, so did just now. Using the same timer setup, Nilem's code runs in .44 seconds, yours runs in 1.16. Not a big difference between the two; they're both much faster than I had any right to expect. Thanks for showing me a different way to approach the problem.

[wallyeye]

No need to be sorry, I'll take a look at his code and try to learn from it.

[jomili]

You and me both.