Why is this locking up? Loop through all rows, perform function on duplicate, delete duplicate row

Question

The code works when I bite off a couple hundred rows at a time, but always hangs somewhere in the middle when I try to run it on 10,000.

What the code does:

Answer 1

Here is a routine that should run quite rapidly. You will note near the top of the code where to change the source and results worksheets if you want.

The work is done within VBA arrays, which will be much faster than working on the worksheet.

I create a User defined object whose properties are the contents of the TestColumn; the Maximum amount in Column B; and an array of the Sum of Columns C, D and E.

These are placed into a Collection object with the Key being the TestColumn. If there is a duplicate, the Collection object will return a 457 error, which we test for and use to combine the rows.

Finally, we write the collection object back to an array, and write that array to the worksheet.

You will use both a Class Module and a Regular Module

The original data does not need to be sorted, but you can if you want, either before or after running this macro.

Enjoy.

Class Module

Be sure to rename this module cCombo after inserting it

Rename this module **cCombo**
Option Explicit
Private pTestColumn As String
Private pMaxColumn As Double
Private pSumColumns(3 To 5) As Variant

Public Property Get TestColumn() As String
    TestColumn = pTestColumn
End Property
Public Property Let TestColumn(Value As String)
    pTestColumn = Value
End Property

Public Property Get MaxColumn() As Double
    MaxColumn = pMaxColumn
End Property
Public Property Let MaxColumn(Value As Double)
    pMaxColumn = IIf(pMaxColumn > Value, pMaxColumn, Value)
End Property

Public Property Get SumColumns() As Variant
    SumColumns = pSumColumns
End Property
Public Property Let SumColumns(Value As Variant)
    Dim I As Long
    For I = LBound(Value) To UBound(Value)
        pSumColumns(I) = pSumColumns(I) + Value(I)
    Next I
End Property

Regular Module

Option Explicit

Sub combineDelete()
  Const TEST_COLUMN As String = "A"
  Dim vSrc As Variant, vRes As Variant, rRes As Range
  Dim wsSrc As Worksheet, wsRes As Worksheet
  Dim cC As cCombo, colC As Collection
  Dim I As Long, J As Long, V As Variant, S As String

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2") 'could be same sheet if you want to overwrite
    Set rRes = wsRes.Cells(2, 1)

'Get original data
With wsSrc
    vSrc = Range(.Cells(2, TEST_COLUMN), .Cells(.Rows.Count, TEST_COLUMN).End(xlUp)).Resize(columnsize:=5)
End With
ReDim V(3 To UBound(vSrc, 2)) 'for storing rows

'Collect the data, eliminating duplicates
Set colC = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc, 1)
    Set cC = New cCombo
    With cC
        .TestColumn = vSrc(I, 1)
        .MaxColumn = vSrc(I, 2)
        For J = 3 To UBound(vSrc, 2)
            V(J) = vSrc(I, J)
        Next J
        .SumColumns = V

        colC.Add Item:=cC, Key:=.TestColumn
        Select Case Err.Number
            Case 457
                Err.Clear
                colC(.TestColumn).MaxColumn = .MaxColumn
                colC(.TestColumn).SumColumns = .SumColumns
            Case Is <> 0
                Debug.Print Err.Number, Err.Description
                Stop
        End Select
    End With
Next I
On Error GoTo 0

'Create results array
ReDim vRes(1 To colC.Count, 1 To 5)
For I = 1 To colC.Count
    With colC(I)
        vRes(I, 1) = .TestColumn
        vRes(I, 2) = .MaxColumn
        V = .SumColumns
        For J = LBound(V) To UBound(V)
            vRes(I, J) = V(J)
        Next J
    End With
Next I

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.ColumnWidth = 5
End With

End Sub