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

Answer 2

Start with this and let us know how things are going afterwards:

Option Explicit

Sub combineDelete()

Const TEST_COLUMN As String = "A"
Dim i As Long
Dim iLastRow As Long
Dim s As Double, t As Double, u As Double
Dim v As Double, w As Double, y As Double

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

With ActiveSheet
    iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
    For i = iLastRow To 2 Step -1
        If .Cells(i, 1).Value2 = .Cells(i - 1, 1).Value2 Then
            s = .Cells(i, 3).Value2
            t = .Cells(i - 1, 3).Value2
            .Cells(i - 1, 3).Value2 = s + t
            u = .Cells(i, 4).Value2
            v = .Cells(i - 1, 4).Value2
            .Cells(i - 1, 4).Value2 = u + v
            w = .Cells(i, 5).Value2
            y = .Cells(i - 1, 5).Value2
            .Cells(i - 1, 5).Value2 = w + y
            .Rows(i).EntireRow.Delete
        End If
    Next i
End With

With Application
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

End Sub

Notes:

1. Disable screenupdating, calculations and events
2. Use .Value2 instead of .Value
3. Explicit coding
4. Missing references to ActiveSheet added by adding dots .
5. Dim all variables to avoid variants

Answer 3

Working with ~10K rows would benefit immensely from a variant array but you can also make significant improvements by deleting all of the rows at once. While you could gather a Union of the rows to delete, a Range.RemoveDuplicates method is also appropriate in this case.

It is unclear on whether your data is sorted on a primary key of column A. Your current code depends upon this but I've changed the criteria check to the Excel Application object's MATCH function to accommodate unsorted data.

Your code appears to avoid text column header labels in row 1. I've used the Range.CurrentRegion property to localize the cells to be processed.

Sub combineDelete()
    Const TEST_COLUMN As String = "A"
    Dim i As Long, mtch As Long

    'appTGGL bTGGL:=False 'uncomment this line once you have completed debugging

    With ActiveSheet
        With .Cells(1, 1).CurrentRegion
            For i = .Rows.Count To 2 Step -1
                mtch = Application.Match(.Cells(i, 1).Value, .Columns(1), 0)
                If mtch < i Then
                    .Cells(mtch, 3) = Application.Sum(.Cells(mtch, 3), .Cells(i, 3))
                    .Cells(mtch, 4) = Application.Sum(.Cells(mtch, 4), .Cells(i, 4))
                    .Cells(mtch, 5) = Application.Sum(.Cells(mtch, 5), .Cells(i, 5))
                End If
            Next i
            .RemoveDuplicates Columns:=1, Header:=xlYes
        End With
    End With

    appTGGL

End Sub

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .ScreenUpdating = bTGGL
        .EnableEvents = bTGGL
        .DisplayAlerts = bTGGL
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
        .StatusBar = vbNullString
    End With
    Debug.Print Timer
End Sub

The use of Application.Sum(..., ...) is a trifle slower than straight addition but it has the benefit of providing error control over text values. This may or may not be a desired behavior; i.e. you might want to know when you are trying to add text to a number instead of skipping over it.

There were many places inside your With ... End With statement where you used Cells(i, 3) and not .Cells(i, 3) (note the prefix . ). If you are going to take the time to reference the Range.Parent property (and you should always do so!) then it seems a shame not to use it.

I've included a reusable 'helper' sub that 'turns off' many application environment states but left it commented. Uncomment it once you havew completed debugging for additional speed and stability.

Addendum for lookup strings with length > 255

Sub combineDelete()
    Dim i As Long, mtch As Long
    Dim vCOLAs As Variant, dCOLAs As Object

    'appTGGL bTGGL:=False 'uncomment this line once you have completed debugging

    Set dCOLAs = CreateObject("Scripting.Dictionary")
    dCOLAs.CompareMode = vbTextCompare

    With ActiveSheet
        With .Cells(1, 1).CurrentRegion
            'strings in column A may exceed 255 chars; build array and and a dictionary from array
            vCOLAs = .Resize(.Rows.Count, 1).Value2
            For i = UBound(vCOLAs, 1) To LBound(vCOLAs, 1) Step -1
                'fast overwrite method
                dCOLAs.Item(vCOLAs(i, 1)) = i
            Next i
            For i = .Rows.Count To 2 Step -1
                mtch = dCOLAs.Item(vCOLAs(i, 1))
                If mtch < i Then
                    .Cells(mtch, 3) = Application.Sum(.Cells(mtch, 3), .Cells(i, 3))
                    .Cells(mtch, 4) = Application.Sum(.Cells(mtch, 4), .Cells(i, 4))
                    .Cells(mtch, 5) = Application.Sum(.Cells(mtch, 5), .Cells(i, 5))
                End If
            Next i
            .RemoveDuplicates Columns:=1, Header:=xlYes
        End With
    End With

    Erase vCOLAs
    dCOLAs.RemoveAll: Set dCOLAs = Nothing

    appTGGL

End Sub

A dictionary object provides lightning fast lookups due to its unique keys. Since these are a variant type, there is no 255 character limit.