Il modo più veloce per eliminare le righe che non possono essere afferrate con SpecialCells

Sulla base di un’altra domanda su questo sito ho iniziato a chiedermi il modo più veloce per eliminare tutte le righe con una determinata condizione.

La domanda di riferimento sopra è venuto con varie soluzioni:

(1) Passa attraverso tutte le righe sul foglio (indietro) ed elimina tutte le righe una per una che soddisfano la condizione.

(2) Spostare prima l’intervallo applicabile in un array, quindi valutare le condizioni nell’array e, in base a ciò, eliminare tutte le righe uno ad uno sul foglio sottostante.

Un ansible miglioramento potrebbe consistere nell’eliminare tutte le righe in blocchi per ridurre il sovraccarico dell’accesso al foglio di lavoro. Ma se segui questo percorso, hai diverse opzioni per “memorizzare” gli intervalli prima di eliminarli effettivamente:

(1) Usa Intersect per unire gli intervalli che dovrebbero essere cancellati.

(2) Basta scrivere una String con tutte le righe da eliminare.

Quindi, qual è il modo più veloce per farlo?

Una soluzione efficace consiste nel taggare tutte le righe per mantenere e spostare tutte le righe da eliminare alla fine ordinando i tag. In questo modo, la complessità non aumenta con il numero di righe da eliminare.

Questo esempio elimina in meno di un secondo, per 50000 righe, tutte le righe in cui la colonna I è uguale a 2 :

 Sub DeleteMatchingRows() Dim rgTable As Range, rgTags As Range, data(), tags(), count&, r& ' load the data in an array Set rgTable = ActiveSheet.UsedRange data = rgTable.Value ' tag all the rows to keep with the row number. Leave empty otherwise. ReDim tags(1 To UBound(data), 1 To 1) tags(1, 1) = 1 ' keep the header For r = 2 To UBound(data) If data(r, 9) <> 2 Then tags(r, 1) = r ' if column I <> 2 keep the row Next ' insert the tags in the last column on the right Set rgTags = rgTable.Columns(rgTable.Columns.count + 1) rgTags.Value = tags ' sort the rows on the tags which will move the rows to delete at the end Union(rgTable, rgTags).Sort key1:=rgTags, Orientation:=xlTopToBottom, Header:=xlYes count = rgTags.End(xlDown).Row ' delete the tags on the right and the rows that weren't tagged rgTags.EntireColumn.Delete rgTable.Resize(UBound(data) - count + 1).Offset(count).EntireRow.Delete End Sub 

Si noti che non altera l’ordine delle righe.

Ecco tutte le possibili opzioni a cui posso pensare con un “tempo medio” per completare le attività:

 Option Base 1 Option Explicit Sub FixWithArraysAndDeleteRange() Dim lngItem As Long Dim varArray() As Variant Dim wksItem As Worksheet Dim rngRangeToDelete As Range Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) varArray() = wksItem.Range("I25:I50000").Value2 For lngItem = LBound(varArray) To UBound(varArray) If IsNumeric(varArray(lngItem, 1)) Then If Int(varArray(lngItem, 1)) = 2 Then If rngRangeToDelete Is Nothing Then Set rngRangeToDelete = wksItem.Rows(lngItem + 24) Else Set rngRangeToDelete = Intersect(rngRangeToDelete, wksItem.Rows(lngItem + 24)) End If End If End If Next lngItem rngRangeToDelete.EntireRow.Delete Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time around 0 seconds End Sub 

 Sub FixWithLoop() Dim lngRow As Long Dim lngLastRow As Long Dim wksItem As Worksheet Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) lngLastRow = wksItem.Cells(wksItem.Rows.Count, "I").End(xlUp).Row For lngRow = lngLastRow To 25 Step -1 If Int(wksItem.Cells(lngRow, "I").Value) = 2 Then wksItem.Rows(lngRow).Delete Next lngRow Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time ~3 seconds End Sub 

 Sub FixWithLoopInChunks() Dim lngRow As Long Dim lngLastRow As Long Dim wksItem As Worksheet Dim strRowsToDelete As String Dim intDeleteCount As Integer Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) lngLastRow = wksItem.Cells(wksItem.Rows.Count, "I").End(xlUp).Row For lngRow = lngLastRow To 25 Step -1 If Int(wksItem.Cells(lngRow, "I").Value) = 2 Then intDeleteCount = intDeleteCount + 1 strRowsToDelete = strRowsToDelete & ",I" & lngRow End If If intDeleteCount >= 30 Then strRowsToDelete = Mid(strRowsToDelete, 2) wksItem.Range(strRowsToDelete).EntireRow.Delete intDeleteCount = 0 strRowsToDelete = "" End If Next lngRow If intDeleteCount > 0 Then strRowsToDelete = Mid(strRowsToDelete, 2) wksItem.Range(strRowsToDelete).EntireRow.Delete End If Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time ~3 seconds End Sub 

 Sub FixWithArraysAndDeleteChunks() Dim lngItem As Long Dim varArray() As Variant Dim wksItem As Worksheet Dim strRowsToDelete As String Dim intDeleteCount As Integer Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) varArray() = wksItem.Range("I25:I50000").Value2 For lngItem = UBound(varArray) To LBound(varArray) Step -1 If IsNumeric(varArray(lngItem, 1)) Then If Int(varArray(lngItem, 1)) = 2 Then intDeleteCount = intDeleteCount + 1 strRowsToDelete = strRowsToDelete & ",I" & lngItem + 24 End If If intDeleteCount >= 30 Then strRowsToDelete = Mid(strRowsToDelete, 2) wksItem.Range(strRowsToDelete).EntireRow.Delete intDeleteCount = 0 strRowsToDelete = "" End If End If Next lngItem If intDeleteCount > 0 Then strRowsToDelete = Mid(strRowsToDelete, 2) wksItem.Range(strRowsToDelete).EntireRow.Delete End If Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time ~2 seconds End Sub 

In base ai test precedenti, il percorso “più veloce” consiste nell’utilizzare un array, salvare l’intervallo di righe da eliminare utilizzando Intersect e quindi eliminare tutte le righe insieme.

Nota, se stai utilizzando Application.Union invece di Intersect il tempo di tale approccio diminuisce in modo significativo e il sub verrà eseguito per quasi 30 secondi.

Tuttavia, la differenza di orario è molto piccola e trascurabile (per 50.000 righe).

Per favore fatemi sapere se il mio test di velocità ha qualche difetto che potrebbe influenzare i risultati o se mi manca un altro approccio che vorreste vedere.

Aggiornare:

Ecco un altro approccio offerto da @SiddharthRout. Non desidero plagiare. Eppure, volevo confrontare i risultati del tempo. Quindi, ecco il sub-riscritto da confrontare con gli altri con il tempo medio registrato sul mio sistema.

 Sub DeleteFilteredRows_SiddharthRout() Dim wksItem As Worksheet Dim rngRowsToDelete As Range Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) wksItem.AutoFilterMode = False wksItem.Range("I25:I50000").AutoFilter Field:=1, Criteria1:=2 Set rngRowsToDelete = wksItem.Range("I25:I50000").SpecialCells(xlCellTypeVisible) wksItem.AutoFilterMode = False wksItem.Rows.Hidden = False rngRowsToDelete.EntireRow.Delete Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time around 5 seconds End Sub 

Sembra che questo approccio sia leggermente più lento rispetto a tutti gli altri.

modificato

dopo altri test sembra che Sort & Delete sia un po ‘più veloce di RemoveDuplicates

quindi ho inserito la seguente soluzione (mantenendo la prima per riferimento alla fine della risposta)

 Sub FixWithSort() Dim testRng As Range Dim dttStart As Date Set testRng = Worksheets("Test").Range("I25:I50000") With testRng .Formula = "=RandBetween(1, 5)" .Value2 = .Value2 End With dttStart = Now() With testRng With .Offset(, 1) .FormulaR1C1 = "=IF(RC[-1]=2,"""",row())" .Value2 = .Value2 End With .Resize(, 2).Sort key1:=.Columns(2), Orientation:=xlTopToBottom, Header:=xlYes Range(.Cells(1, 2).End(xlDown).Offset(1, -1), .Cells(1, 1).End(xlDown)).EntireRow.Delete .Columns(2).ClearContents End With Debug.Print Format(Now() - dttStart, "HH:MM:SS") dttStartGlobal = dttStartGlobal + Now() - dttStart End Sub 

soluzione precedente (e un po ‘più lenta) con RemoveDuplicates

 Option Explicit Sub FixWithRemoveDuplicates() Dim testRng As Range Dim dttStart As Date Set testRng = Worksheets("Test").Range("I25:I50000") With testRng .Formula = "=RandBetween(1, 5)" .Value2 = .Value2 End With dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False With testRng With .Offset(, 1) .FormulaR1C1 = "=IF(RC[-1]=2,""a"",row())" .Value2 = .Value2 End With .EntireRow.RemoveDuplicates Columns:=Array(.Columns(2).Column), Header:=xlNo .Offset(, 1).Find(what:="a", LookIn:=xlValues, LookAt:=xlWhole).EntireRow.Delete .Columns(2).ClearContents End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time around 0 seconds End Sub