比使用union删除行范围更快的方法

Question

我使用下面的代码:
Delete the similar rows, keeping only one and combine cells values in the range "N", separated by vbLf
它工作，但有大范围(例如30万行)宏需要很长时间才能完成。
在调试代码后，我发现使用union会导致宏需要很长时间才能完成。

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

所以下面的代码，如何适应一个更快的方法来删除行范围，而不是使用联合?事先，感谢任何有帮助的评论和回答。

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随着向范围添加更多单元格/区域而逐渐变慢(参见此处的数字:https://stackoverflow.com/a/56573408/478884)。如果你是"自下而上"工作的话;你可以删除rngDel每(例如)500行，但你不能采取这种方法，因为你是自上而下的工作。

这里有一种不同的方法-将单元格添加到集合中，然后"自下而上"地处理集合。最后，使用批处理删除进程。

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

时间(秒)-注意随着行数的增加，单次删除和批量删除的方式是如何不同的。

# 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

您还可以考虑填充"delete"标记，然后使用自动过滤/删除可见行方法(EDIT: add as method #3)

Answer 2

将此作为实际用例的工作(但更快)版本发布，因为我的另一个答案实际上只是关于不同方法的计时。

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