vacias - Rendimiento de Excel VBA: 1 millón de filas: elimine filas que contengan un valor, en menos de 1 minuto

macro para eliminar columnas especificas

Question

Estoy tratando de encontrar una manera de filtrar datos grandes y eliminar filas en una hoja de trabajo, en menos de un minuto

La meta:

• Encuentre todos los registros que contengan texto específico en la columna 1 y elimine toda la fila
• Mantenga todos los formatos de celda (colores, fuente, bordes, anchos de columna) y fórmulas tal como están

.

Datos de prueba:

:

.

Cómo funciona el código:

1. Comienza desactivando todas las funciones de Excel

2. Si el libro no está vacío y el valor de texto a eliminar existe en la columna 1

   • Copia el rango utilizado de la columna 1 a una matriz
   • Itera sobre cada valor en la matriz al revés

   • Cuando encuentra una coincidencia:

     • Añade la dirección de la celda a una cadena tmp en el formato "A11,A275,A3900,..."
     • Si la longitud variable de tmp es cercana a 255 caracteres
     • Elimina filas usando .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp
     • Restablece tmp para vaciarlo y pasa al siguiente conjunto de filas
3. Al final, vuelve a activar todas las funciones de Excel

.

El problema principal es la operación Eliminar , y el tiempo de duración total debe ser inferior a un minuto. Cualquier solución basada en código es aceptable siempre que funcione por debajo de 1 minuto.

Esto reduce el alcance a muy pocas respuestas aceptables. Las respuestas ya proporcionadas también son muy cortas y fáciles de implementar. One realiza la operación en aproximadamente 30 segundos, por lo que hay al menos una respuesta que proporciona una solución aceptable, y otra puede resultarle útil también

.

Mi principal función inicial:

Sub DeleteRowsWithValuesStrings()
Const MAX_SZ As Byte = 240
Dim i As Long, j As Long, t As Double, ws As Worksheet
Dim memArr As Variant, max As Long, tmp As String
Set ws = Worksheets(1)
max = GetMaxCell(ws.UsedRange).Row
FastWB True: t = Timer
With ws
If max > 1 Then
If IndexOfValInRowOrCol("Test String", , ws.UsedRange) > 0 Then
memArr = .Range(.Cells(1, 1), .Cells(max, 1)).Value2
For i = max To 1 Step -1
If memArr(i, 1) = "Test String" Then
tmp = tmp & "A" & i & ","
If Len(tmp) > MAX_SZ Then
.Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp
tmp = vbNullString
End If
End If
Next
If Len(tmp) > 0 Then
.Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp
End If
.Calculate
End If
End If
End With
FastWB False: InputBox "Duration: ", "Duration", Timer - t
End Sub

Funciones de ayuda (active y desactive las funciones de Excel):

Public Sub FastWB(Optional ByVal opt As Boolean = True)
With Application
.Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
.DisplayAlerts = Not opt
.DisplayStatusBar = Not opt
.EnableAnimations = Not opt
.EnableEvents = Not opt
.ScreenUpdating = Not opt
End With
FastWS , opt
End Sub
Public Sub FastWS(Optional ByVal ws As Worksheet = Nothing, _
Optional ByVal opt As Boolean = True)
If ws Is Nothing Then
For Each ws In Application.ActiveWorkbook.Sheets
EnableWS ws, opt
Next
Else
EnableWS ws, opt
End If
End Sub
Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
With ws
.DisplayPageBreaks = False
.EnableCalculation = Not opt
.EnableFormatConditionsCalculation = Not opt
.EnablePivotTable = Not opt
End With
End Sub

Encuentra la última celda con datos (gracias @ZygD, ahora lo probé en varios escenarios):

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
''Returns the last cell containing a value, or A1 if Worksheet is empty
Const NONEMPTY As String = "*"
Dim lRow As Range, lCol As Range
If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
If WorksheetFunction.CountA(rng) = 0 Then
Set GetMaxCell = rng.Parent.Cells(1, 1)
Else
With rng
Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows)
If Not lRow Is Nothing Then
Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns)
Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
End If
End With
End If
End Function

Devuelve el índice de una coincidencia en la matriz, o 0 si no se encuentra una coincidencia:

Public Function IndexOfValInRowOrCol( _
ByVal searchVal As String, _
Optional ByRef ws As Worksheet = Nothing, _
Optional ByRef rng As Range = Nothing, _
Optional ByRef vertical As Boolean = True, _
Optional ByRef rowOrColNum As Long = 1 _
) As Long
''Returns position in Row or Column, or 0 if no matches found
Dim usedRng As Range, result As Variant, searchRow As Long, searchCol As Long
result = CVErr(9999) ''- generate custom error
Set usedRng = GetUsedRng(ws, rng)
If Not usedRng Is Nothing Then
If rowOrColNum < 1 Then rowOrColNum = 1
With Application
If vertical Then
result = .Match(searchVal, rng.Columns(rowOrColNum), 0)
Else
result = .Match(searchVal, rng.Rows(rowOrColNum), 0)
End If
End With
End If
If IsError(result) Then IndexOfValInRowOrCol = 0 Else IndexOfValInRowOrCol = result
End Function

.

Actualizar:

6 soluciones probadas (3 pruebas cada una): la solución de Excel Hero es la más rápida hasta ahora (elimina fórmulas)

.

Aquí están los resultados, del más rápido al más lento:

.

Prueba 1. Total de 100,000 registros, 10,000 para eliminar:

1. ExcelHero() - 1.5 seconds
2. DeleteRowsWithValuesNewSheet() - 2.4 seconds
3. DeleteRowsWithValuesStrings() - 2.45 minutes
4. DeleteRowsWithValuesArray() - 2.45 minutes
5. QuickAndEasy() - 3.25 minutes
6. DeleteRowsWithValuesUnion() - Stopped after 5 minutes

.

Prueba 2. Total de 1 millón de registros, 100,000 para eliminar:

1. ExcelHero() - 16 seconds (average)
2. DeleteRowsWithValuesNewSheet() - 33 seconds (average)
3. DeleteRowsWithValuesStrings() - 4 hrs 38 min (16701.375 sec)
4. DeleteRowsWithValuesArray() - 4 hrs 37 min (16626.3051757813 sec)
5. QuickAndEasy() - 5 hrs 40 min (20434.2104492188 sec)
6. DeleteRowsWithValuesUnion() - N/A

.

Notas:

1. Método ExcelHero: fácil de implementar, confiable, extremadamente rápido, pero elimina fórmulas
2. Método NewSheet: fácil de implementar, confiable y cumple con el objetivo
3. Método de cadenas: más esfuerzo para implementar, confiable, pero no cumple con los requisitos
4. Método de matriz: similar a Strings, pero ReDims una matriz (versión más rápida de Union)
5. QuickAndEasy: fácil de implementar (corto, confiable y elegante), pero no cumple con los requisitos
6. Range Union: complejidad de implementación similar a 2 y 3, pero demasiado lenta

También hice los datos de prueba más realistas al introducir valores inusuales:

• celdas vacías, rangos, filas y columnas
• caracteres especiales, como = [`~! @ # $% ^ & * () _- + {} [] / |;: ''",. <> / ?, combinaciones separadas y múltiples
• espacios en blanco, pestañas, fórmulas vacías, borde, fuente y otro formato de celda
• números grandes y pequeños con decimales (= 12.9999999999999 + 0.00000000000000001)
• hipervínculos, reglas de formato condicional
• formato vacío dentro y fuera de los rangos de datos
• cualquier otra cosa que pueda causar problemas de datos

Answer 1

El uso de matrices para calcular el rango utilizado y el recuento de filas puede afectar el rendimiento. Aquí hay otro enfoque que, en las pruebas, resulta eficiente en más de 1 millón de filas de datos, entre 25-30 segundos. No utiliza filtros, por lo que eliminará las filas incluso si están ocultas. Eliminar una fila completa no afectará el formato o el ancho de columna de las otras filas restantes.

1. Primero, verifique si ActiveSheet tiene "Cadena de prueba". Como solo te interesa la columna 1, utilicé esto:

   TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
   If TCount > 0 Then

2. En lugar de usar su función GetMaxCell () simplemente usé Cells.SpecialCells(xlCellTypeLastCell).Row para obtener la última fila:

   EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row

3. Luego recorra las filas de datos:

   While r <= EndRow

4. Para probar si la celda en la Columna 1 es igual a "Cadena de prueba":

   If sht.Cells(r, 1).Text) = "Test String" Then

5. Para eliminar la fila:

   Rows(r).Delete Shift:=xlUp

Poniendo todo junto el código completo a continuación. Establecí ActiveSheet en una variable Sht y agregué activado ScreenUpdating para mejorar la eficiencia. Como son muchos datos, me aseguro de borrar las variables al final.

Sub RowDeleter()
Dim sht As Worksheet
Dim r As Long
Dim EndRow As Long
Dim TCount As Long
Dim s As Date
Dim e As Date
Application.ScreenUpdating = True
r = 2 ''Initialise row number
s = Now ''Start Time
Set sht = ActiveSheet
EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
''Check if "Test String" is found in Column 1
TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
If TCount > 0 Then
''loop through to the End row
While r <= EndRow
If InStr(sht.Cells(r, 1).Text, "Test String") > 0 Then
sht.Rows(r).Delete Shift:=xlUp
r = r - 1
End If
r = r + 1
Wend
End If
e = Now ''End Time
D = (Hour(e) * 360 + Minute(e) * 60 + Second(e)) - (Hour(s) * 360 + Minute(s) * 60 + Second(s))
Application.ScreenUpdating = True
DurationTime = TimeSerial(0, 0, D)
MsgBox Format(DurationTime, "hh:mm:ss")
End Sub

Answer 2

En mi viejo Dell Inspiron 1564 (Win 7 Office 2007) esto:

Sub QuickAndEasy()
Dim rng As Range
Set rng = Range("AA2:AA1000001")
Range("AB1") = Now
Application.ScreenUpdating = False
With rng
.Formula = "=If(A2=""Test String"",0/0,A2)"
.Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
.Clear
End With
Application.ScreenUpdating = True
Range("AC1") = Now
End Sub

tardó unos 10 segundos en ejecutarse. Supongo que la columna AA está disponible.

EDITAR # 1:

Tenga en cuenta que este código no establece el cálculo en Manual. El rendimiento mejorará si el modo de cálculo se establece en Manual después de que la columna "auxiliar" pueda calcular.

Answer 3

Estoy proporcionando la primera respuesta como referencia

Otros pueden encontrarlo útil, si no hay otras opciones disponibles

• La forma más rápida de lograr el resultado es no usar la operación Eliminar
• De 1 millón de registros, elimina 100,000 filas en un promedio de 33 segundos

.

Sub DeleteRowsWithValuesNewSheet() ''100K records 10K to delete
''Test 1: 2.40234375 sec
''Test 2: 2.41796875 sec
''Test 3: 2.40234375 sec
''1M records 100K to delete
''Test 1: 32.9140625 sec
''Test 2: 33.1484375 sec
''Test 3: 32.90625 sec
Dim oldWs As Worksheet, newWs As Worksheet, rowHeights() As Long
Dim wsName As String, t As Double, oldUsedRng As Range
FastWB True: t = Timer
Set oldWs = Worksheets(1)
wsName = oldWs.Name
Set oldUsedRng = oldWs.Range("A1", GetMaxCell(oldWs.UsedRange))
If oldUsedRng.Rows.Count > 1 Then ''If sheet is not empty
Set newWs = Sheets.Add(After:=oldWs) ''Add new sheet
With oldUsedRng
.AutoFilter Field:=1, Criteria1:="<>Test String"
.Copy ''Copy visible data
End With
With newWs.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll ''Paste data on new sheet
.Cells(1, 1).Select ''Deselect paste area
.Cells(1, 1).Copy ''Clear Clipboard
End With
oldWs.Delete ''Delete old sheet
newWs.Name = wsName
End If
FastWB False: InputBox "Duration: ", "Duration", Timer - t
End Sub

.

A alto nivel:

• Crea una nueva hoja de trabajo y mantiene una referencia a la hoja inicial.
• AutoFiltros columna 1 en el texto buscado: .AutoFilter Field:=1, Criteria1:="<>Test String"
• Copia todos los datos (visibles) de la hoja inicial
• Pega anchos de columna, formatos y datos a la nueva hoja
• Elimina la hoja inicial
• Renombra la nueva hoja al nombre de la hoja anterior

Utiliza las mismas funciones auxiliares publicadas en la pregunta

El 99% de la duración es utilizada por el Autofiltro

.

Hay un par de limitaciones que encontré hasta ahora, la primera se puede abordar:

1. Si hay filas ocultas en la hoja inicial, las muestra

   • Se necesita una función separada para ocultarlos
   • Dependiendo de la implementación, puede aumentar significativamente la duración

2. VBA relacionado:

   • Cambia el nombre del código de la hoja; otros VBA que se refieran a la Hoja 1 se romperán (si corresponde)
   • Elimina todo el código VBA asociado con la hoja inicial (si existe)

.

Algunas notas sobre el uso de archivos grandes como este:

• El formato binario (.xlsb) reduce drásticamente el tamaño del archivo (de 137 Mb a 43 Mb)

• Las reglas de formato condicional no administrado pueden causar problemas de rendimiento exponencial

  • Lo mismo para comentarios y validación de datos

• Leer archivos o datos de la red es mucho más lento que trabajar con un archivo locall

Answer 4

Sé que llego increíblemente tarde con mi respuesta aquí, sin embargo, los futuros visitantes pueden encontrarlo muy útil.

Tenga en cuenta: mi enfoque requiere una columna de índice para que las filas terminen en el orden original, sin embargo, si no le importa que las filas estén en un orden diferente, entonces no se necesita una columna de índice y se puede eliminar la línea de código adicional .

Mi enfoque: Mi enfoque era simplemente seleccionar todas las filas en el rango seleccionado (columna), ordenarlas en orden ascendente usando Range.Sort y luego recolectar el primer y último índice de "Test String" dentro del rango seleccionado (columna). Luego creo un rango a partir del primer y último índice y uso Range.EntrieRow.Delete para eliminar todas las filas que contienen "Test String" .

Pros:
- Está ardiendo rápido.
- No elimina el formato, las fórmulas, los gráficos, las imágenes ni nada parecido al método que se copia en una nueva hoja.

Contras:
- Un tamaño decente de código para implementar, sin embargo, todo es sencillo.

Prueba Rango Generación Sub:

Sub DevelopTest()
Dim index As Long
FastWB True
ActiveSheet.UsedRange.Clear
For index = 1 To 1000000 ''1 million test
ActiveSheet.Cells(index, 1).Value = index
If (index Mod 10) = 0 Then
ActiveSheet.Cells(index, 2).Value = "Test String"
Else
ActiveSheet.Cells(index, 2).Value = "Blah Blah Blah"
End If
Next index
Application.StatusBar = ""
FastWB False
End Sub

Filtrar y eliminar filas Sub:

Sub DeleteRowFast()
Dim curWorksheet As Worksheet ''Current worksheet vairable
Dim rangeSelection As Range ''Selected range
Dim startBadVals As Long ''Start of the unwanted values
Dim endBadVals As Long ''End of the unwanted values
Dim strtTime As Double ''Timer variable
Dim lastRow As Long ''Last Row variable
Dim lastColumn As Long ''Last column variable
Dim indexCell As Range ''Index range start
Dim sortRange As Range ''The range which the sort is applied to
Dim currRow As Range ''Current Row index for the for loop
Dim cell As Range ''Current cell for use in the for loop
On Error GoTo Err
Set rangeSelection = Application.InputBox("Select the (N=) range to be checked", "Get Range", Type:=8) ''Get the desired range from the user
Err.Clear
M1 = MsgBox("This is recommended for large files (50,000 or more entries)", vbYesNo, "Enable Fast Workbook?") ''Prompt the user with an option to enable Fast Workbook, roughly 150% performace gains... Recommended for incredibly large files
Select Case M1
Case vbYes
FastWB True ''Enable fast workbook
Case vbNo
FastWB False ''Disable fast workbook
End Select
strtTime = Timer ''Begin the timer
Set curWorksheet = ActiveSheet
lastRow = CLng(rangeSelection.SpecialCells(xlCellTypeLastCell).Row)
lastColumn = curWorksheet.Cells(1, 16384).End(xlToLeft).Column
Set indexCell = curWorksheet.Cells(1, 1)
On Error Resume Next
If rangeSelection.Rows.Count > 1 Then ''Check if there is anything to do
lastVisRow = rangeSelection.Rows.Count
Set sortRange = curWorksheet.Range(indexCell, curWorksheet.Cells(curWorksheet.Rows(lastRow).Row, 16384).End(xlToLeft)) ''Set the sort range
sortRange.Sort Key1:=rangeSelection.Cells(1, 1), Order1:=xlAscending, Header:=xlNo ''Sort by values, lowest to highest
startBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, MatchCase:=False).Row
endBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False).Row
curWorksheet.Range(curWorksheet.Rows(startBadVals), curWorksheet.Rows(endBadVals)).EntireRow.Delete ''Delete uneeded rows, deleteing in continuous range blocks is quick than seperated or individual deletions.
sortRange.Sort Key1:=indexCell, Order1:=xlAscending, Header:=xlNo ''Sort by index instead of values, lowest to highest
End If
Application.StatusBar = "" ''Reset the status bar
FastWB False ''Disable fast workbook
MsgBox CStr(Round(Timer - strtTime, 2)) & "s" ''Display duration of task
Err:
Exit Sub
End Sub

¡ESTE CÓDIGO UTILIZA FastWB , FastWS Y EnableWS POR Paul Bica!

Veces a 100K entradas (se eliminarán 10k, FastWB True):
1. 0.2 segundos.
2. 0.2 segundos.
3. 0.21 segundos.
Media 0.2 segundos

Veces a 1 millón de entradas (se eliminarán 100k, FastWB True):
1. 2.3 segundos.
2. 2.32 segundos.
3. 2.3 segundos.
Media 2,31 segundos.

Ejecutando en: Windows 10, iMac i3 11,2 (desde 2010)

EDITAR
Este código se diseñó originalmente con el propósito de filtrar valores numéricos fuera de un rango numérico y se ha adaptado para filtrar "Test String" por lo que parte del código puede ser redundante.

Answer 5

Se puede lograr una ganancia significativa de velocidad si los datos de origen no contienen fórmulas, o si el escenario permitiría (o desea) que las fórmulas se conviertan en valores duros durante las eliminaciones de filas condicionales.

Con lo anterior como advertencia, mi solución utiliza el AdvancedFilter del objeto de rango. Es aproximadamente el doble de rápido que DeleteRowsWithValuesNewSheet ().

Public Sub ExcelHero()
Dim t#, crit As Range, data As Range, ws As Worksheet
Dim r&, fc As Range, lc As Range, fr1 As Range, fr2 As Range
FastWB True
t = Timer
Set fc = ActiveSheet.UsedRange.Item(1)
Set lc = GetMaxCell
Set data = ActiveSheet.Range(fc, lc)
Set ws = Sheets.Add
With data
Set fr1 = data.Worksheet.Range(fc, fc.Offset(, lc.Column))
Set fr2 = ws.Range(ws.Cells(fc.Row, fc.Column), ws.Cells(fc.Row, lc.Column))
With fr2
fr1.Copy
.PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAll
.Item(1).Select
End With
Set crit = .Resize(2, 1).Offset(, lc.Column + 1)
crit = [{"Column 1";"<>Test String"}]
.AdvancedFilter xlFilterCopy, crit, fr2
.Worksheet.Delete
End With
FastWB False
r = ws.UsedRange.Rows.Count
Debug.Print "Rows: " & r & ", Duration: " & Timer - t & " seconds"
End Sub