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