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

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

CodePudding user response：

Instead of

   For m = 1 To k 
       If rngDel Is Nothing Then
           Set rngDel = ws.Range("A" & i   m)
       Else
           Set rngDel = Union(rngDel, ws.Range("A" & i   m)) 
       End If
   Next m

try this code

   Set rngDel = ws.Columns("A").Rows(i   1 & ":" & i   k)

CodePudding user response：

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
    Debug.Print "Collected", Timer - t
    RemoveRows colCells
    Debug.Print "Batch-deleted", 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)

# of rows deleted         ~2.5k/10k     ~5k/20k   
-------------------------------------------------------
Regular single delete     10.01         65.9
Collected                 0.008         0.012
Batch-deleted             2.2           4.7