Faster method to delete a range of rows other that using union

Question

I am using the below code to:
Delete the similar rows, keeping only one and combine cells values in the range "N", separated by vbLf
it works ,but with big range (e.g. 30 thousands rows) the macro takes a very long time to finish.
After debugging the code, I find out that using union causes macro to takes a very long time to finish.

Set rngDel = Union(rngDel, ws.Range("A" & i + m))

So with the below code , How to adapt a faster method to delete that range of rows other that using union?
In advance, grateful for any helpful comments and answers.

Sub DeleteSimilarRows_combine_Last_Column_N()
 
    Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
     Dim strVal As String, m As Long
 
      Set ws = ActiveSheet: LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    arrWork = ws.Range("A1:A" & LastRow).Value2 'Place the range in an array to make iteration faster
 
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For i = 2 To UBound(arrWork) - 1                'Iterate between the array elements:
        If arrWork(i, 1) = arrWork(i + 1, 1) Then
            'Determine how many consecutive similar rows exist:______
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k '__
 
            For j = 14 To 14                  'Build the concatenated string of cells in range "N":
                strVal = ws.Cells(i, j).Value
                For m = 1 To k
                    strVal = strVal & vbLf & ws.Cells(i + m, j).Value
                Next m
                ws.Cells(i, j).Value = strVal: strVal = ""
           Next j
 
           For m = 1 To k                    'Place the cells for rows to be deleted in a Union range, to delete at the end, at once
                If rngDel Is Nothing Then
                     Set rngDel = ws.Range("A" & i + m)
                Else
                    Set rngDel = Union(rngDel, ws.Range("A" & i + m)) 'This line causes macro takes very long time to finish.
                End If
         Next m
         i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'Increment the i variable and exiting if the resulted value exits the array size
       End If
    Next i
 
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete    'Delete the not necessary rows
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub

Answer 1

Union gets progressively slower as you add more cells/areas to the range (see numbers here: https://stackoverflow.com/a/56573408/478884). If you were working "bottom up" you could delete rngDel every (eg) 500 rows, but you can't take that approach since you're working top-down.

Here's a different approach - adding cells to a Collection and then processing the collection "bottom-up" at the end, using a batch-delete process.

Sub TestRowDeletion()

    Dim rngRows As Range, data, rngDel As Range, i As Long
    Dim t, nRows As Long, colCells As New Collection
    
    Set rngRows = Range("A1:A10000") '10k rows for testing
    
    'Approach #1 - your existing method
    DummyData rngRows     'populate some dummy data
    data = rngRows.Value
    t = Timer
    For i = 1 To UBound(data, 1)
        'removing ~25% of cells...
        If data(i, 1) > 0.75 Then BuildRange rngDel, rngRows.Cells(i)
    Next i
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
    Debug.Print "Regular single delete", Timer - t

    'Approach #2 - batch-deleting rows
    DummyData rngRows 'reset data
    data = rngRows.Value
    t = Timer
    For i = 1 To UBound(data, 1)
        If data(i, 1) > 0.75 Then colCells.Add rngRows.Cells(i)
    Next i
    RemoveRows colCells
    Debug.Print "Batch-deleted", Timer - t

    'Approach #3 - array of "delete" flags plus SpecialCells()
    DummyData rngRows 'reset data
    data = rngRows.Value
    t = Timer
    ReDim flags(1 To UBound(data, 1), 1 To UBound(data, 2))
    For i = 1 To UBound(data, 1)
        If data(i, 1) > 0.75 Then
            flags(i, 1) = "x"
            bDelete = True 'flag we have rows to delete
        End If
    Next i
    If bDelete Then
        With rngRows.Offset(0, 10) 'use an empty column....
            .Value = flags  'populate with flags for deletion
            .SpecialCells(xlCellTypeConstants).EntireRow.Delete
        End With
    End If
    Debug.Print "Specialcells", Timer - t

End Sub

'Delete the row for any cell in `col`
'  cells were added to `col` in a "top down" order
Sub RemoveRows(col As Collection)
    Dim rngDel As Range, n As Long
    For n = col.Count To 1 Step -1 'working from the bottom up...
        BuildRange rngDel, col(n)
        If n Mod 250 = 0 Then
            rngDel.EntireRow.Delete
            Set rngDel = Nothing
        End If
    Next n
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub

Sub DummyData(rng As Range)
    With rng
        .Formula = "=RAND()"
        .Value = .Value
    End With
End Sub

Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
    If rngTot Is Nothing Then
        Set rngTot = rngAdd
    Else
        Set rngTot = Application.Union(rngTot, rngAdd)
    End If
End Sub

Times (sec) - note how differently the single-delete and batch-delete approaches scale as more rows are added.

# of rows deleted         ~2.5k/10k    ~5k/20k     ~7.5k/30k 
------------------------------------------------------------
1. Regular single delete     10.01         65.9       226
2. Batch-deleted             2.2           4.7        7.8
3. SpecialCells              1.6           3.1        4.7

You could also consider populating a "delete" flag in your dataset, then using the autofilter/delete visible rows approach (EDIT: added as method #3)

Answer 2

Posting this as a working (but faster) version of your actual use case, since my other answer is really just about timing the different approaches.

Sub DeleteSimilarRowsCombineColumnN()

    Const SEP As String = ","
    Dim arrKeys, arrVals, arrFlags, rngRows As Range, rngVals As Range, i As Long, key, currKey, s As String
    Dim ws As Worksheet, ub As Long, t, n As Long
    
    t = Timer
    Set ws = ActiveSheet
    Set ws = ActiveSheet
    Set rngRows = ws.Range("A1:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row)
    Set rngVals = rngRows.EntireRow.Columns("N")
    
    arrKeys = rngRows.Value
    ub = UBound(arrKeys, 1)
    arrVals = rngVals.Value
    ReDim arrFlags(1 To UBound(arrKeys, 1), 1 To 1)
 
    currKey = Chr(0)     'non-existing key...
    For i = ub To 1 Step -1                      'looping from bottom up
        key = arrKeys(i, 1)                      'this row's key
        If key <> currKey Then                   'different key from row below?
            If i < ub Then arrVals(i + 1, 1) = s 'populate the collected info for any previous key
            s = arrVals(i, 1)                    'collect this row's "N" value
            currKey = key                        'set as current key
        Else
            If i < ub Then
                arrFlags(i + 1, 1) = "x" 'flag for deletion
                n = n + 1
            End If
            s = arrVals(i, 1) & SEP & s             'concatenate the "N" value
        End If
    Next i
    arrVals(1, 1) = s                              'populate the last (first) row...
    rngVals.Value = arrVals                        'drop the concatenated values
    
    If n > 0 Then    'any rows to delete?
        Debug.Print "About to delete " & n & " of " & ub & " rows", Timer - t
        With rngRows.Offset(0, 100) 'use any empty column
            .Value = arrFlags
            .SpecialCells(xlCellTypeConstants).EntireRow.Delete
        End With
        Debug.Print "Done deleting in " & Round(Timer - t, 2) & " sec"
    End If
End Sub