varias - macro para limpiar celdas excel

Código más rápido para eliminar celdas a través de varias hojas de trabajo en excel

Question

Soy un principiante en VB y busqué en Google y revisé las respuestas. He escrito el siguiente ciclo para recorrer varias hojas de trabajo de Excel y eliminar filas donde las celdas contienen elementos específicos (N / A # N / A #).

Los datos en la hoja xl a limpiar son datos financieros con FECHA, ABIERTO. ALTO BAJO CERRAR. el número de filas puede ser significativo y el número de hojas de trabajo puede ser 2-300. Funciona, pero es muy lento y, a medida que estoy aprendiendo, agradecería cualquier ayuda sobre cómo puedo hacer que este código sea más rápido. Gracias.

    Sub DataDeleteStage1()

    ScreenUpdating = False

      Dim lrow As Long
      Dim ws As Worksheet
      Dim icntr As Long


       For Each ws In ThisWorkbook.Worksheets

                lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row
                For icntr = lrow To 1 Step -1

                If ws.Name <> "HEADER" Then
                If ws.Cells(icntr, "B") = "#N/A N/A" And ws.Cells(icntr, "C") = "#N/A N/A" And ws.Cells(icntr, "D") = "#N/A N/A" And ws.Cells(icntr, "E") = "#N/A N/A" Then
                            ws.Rows(icntr).EntireRow.Delete
                End If
                End If

                Next icntr

        Next ws

    End Sub

Answer 1

¿Qué tal esto?

Sub DeleteRows()
Dim ws As Worksheet
With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
End With

For Each ws In ThisWorkbook.Sheets
    If ws.Name <> "HEADER" Then
        On Error Resume Next
        ws.Columns("B:E").Replace "#N/A N/A", "=NA()"
        ws.Columns("B:E").SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete
    End If
Next ws
With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Answer 2

Con AutoFilter y sin bucle en conjunto:

Sub DataDeleteStage1()
Dim ws As Worksheet
Dim lr As Integer
Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets
    With ws
        lr = .Range("A" & .Rows.Count).End(xlUp).Row
        If ws.Name <> "HEADER" Then
            .UsedRange.AutoFilter Field:=2, Criteria1:="#N/A"
            .UsedRange.AutoFilter Field:=3, Criteria1:="#N/A"
            .UsedRange.AutoFilter Field:=4, Criteria1:="#N/A"
            .UsedRange.AutoFilter Field:=5, Criteria1:="#N/A"
            .Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete shift:=xlUp
        End If
    End With
Next ws
Application.ScreenUpdating = True
End Sub

Probado este frente al enfoque de rango combinado en 300K filas - más rápido por minutos al hacer varias hojas.

Answer 3

Intente fusionar todos los Range que se van a eliminar en un objeto MergeRng , y luego simplemente elimínelo todo a la vez.

Código

Sub DataDeleteStage1()

ScreenUpdating = False

Dim lrow As Long
Dim ws As Worksheet
Dim icntr As Long
Dim MergeRng As Range

For Each ws In ThisWorkbook.Worksheets
    With ws
        lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For icntr = lrow To 1 Step -1
            If .Name <> "HEADER" Then
                If .Cells(icntr, "B") = "#N/A N/A" And .Cells(icntr, "C") = "#N/A N/A" And .Cells(icntr, "D") = "#N/A N/A" And .Cells(icntr, "E") = "#N/A N/A" Then
                    If Not MergeRng Is Nothing Then
                        Set MergeRng = Application.Union(MergeRng, .Rows(icntr))
                    Else
                        Set MergeRng = .Rows(icntr)
                    End If
                End If
            End If
        Next icntr

        '' Delete all rows at once
         If Not MergeRng Is Nothing Then MergeRng.Delete
    End With

    Set MergeRng = Nothing '' reset range when changing worksheets

Next ws

End Sub

Answer 4

No he probado, pero prueba esto,

Sub DataDeleteStage1()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim lrow As Long
    Dim ws As Worksheet
    Dim icntr As Long

    For Each ws In ThisWorkbook.Worksheets

        lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row

        If ws.Name <> "HEADER" Then
        On Error Resume Next
            Range("F1:F" & lrow).Formula = "=IF(SUMPRODUCT(--ISERROR(A1:E1))=5,NA(),"""")"
            Range("F1:F" & lrow).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete shift:=xlUp
            Range("F1:F" & lrow).Clear

        End If

    Next ws

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Answer 5

Puede hacer que su código se elimine solo una vez y no todas las veces. Para hacerlo así, intente lo siguiente:

Sub DataDeleteStage1()

    Application.ScreenUpdating = False

    Dim lrow        As Long
    Dim ws          As Worksheet
    Dim icntr       As Long

    Dim delRange    As Range

    For Each ws In ThisWorkbook.Worksheets

        lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row
        For icntr = lrow To 1 Step -1
            If ws.Name <> "HEADER" Then
                If ws.Cells(icntr, "B") = "#N/A N/A" And _
                    ws.Cells(icntr, "C") = "#N/A N/A" And _
                    ws.Cells(icntr, "D") = "#N/A N/A" And _
                    ws.Cells(icntr, "E") = "#N/A N/A" Then

                    If Not delRange Is Nothing Then
                        Set delRange = ws.Rows(icntr)
                    Else
                        Set delRange = Union(delRange, ws.Rows(icntr))
                    End If
                End If
            End If
        Next icntr

        If Not delRange Is Nothing Then delRange.Delete
        Set delRange = Nothing

    Next ws
End Sub

No lo he intentado, pero debería funcionar.