passwort - Schnellerer Code zum Löschen von Zellen über mehrere Arbeitsblätter in Excel



blattschutz excel einrichten (4)

Ich habe es nicht getestet, aber versuche es

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

ich bin ein Anfänger in VB und gegoogelt und durch die Antworten hier geschaut habe ich die folgende Schleife geschrieben, um durch mehrere Excel-Arbeitsblätter zu durchlaufen und Zeilen zu löschen, wo die Zellen bestimmte Elemente enthalten (N / A # N / A #).

Die Daten im zu bereinigenden XL-Blatt sind Finanzdaten mit DATE, OPEN. HOCH UNTER SCHLIESSEN. Die Anzahl der Zeilen kann erheblich sein und die Anzahl der Arbeitsblätter kann 2-300 sein. Es funktioniert, ist aber sehr, sehr langsam und ich lerne - ich würde mich über jede Hilfe freuen, wie ich diesen Code schneller machen kann. Vielen Dank.

    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

Mit AutoFilter und ohne Looping insgesamt:

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

Getestet wurde dies im Vergleich zum Merged-Range-Ansatz bei 300K-Zeilen - bei mehreren Blättern um Minuten schneller.


Answer #2

Versuchen Sie, alle zu MergeRng Range s zu einem MergeRng Objekt zusammenzuführen, und löschen Sie dann alles auf einmal.

Code

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 #3

Wie wäre es damit?

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