excel - une - vba supprimer toutes les lignes sauf la première




Code plus rapide pour supprimer des cellules via plusieurs feuilles de calcul dans Excel (4)

Avec AutoFilter et sans bouclage:

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

Testé par rapport à l'approche de la plage fusionnée sur 300K lignes - plus rapide par minutes lorsque vous faites plusieurs feuilles.

Je suis un débutant en VB et après avoir googlé et parcouru les réponses ici j'ai écrit la boucle suivante pour parcourir plusieurs feuilles de calcul Excel et supprimer les lignes où les cellules contiennent des éléments spécifiques (N / A # N / A #).

Les données de la feuille xl à nettoyer sont des données financières avec DATE, OPEN. HAUTE BASSE FERMÉE. le nombre de lignes peut être significatif et le nombre de feuilles de calcul peut être compris entre 2 et 300. Cela fonctionne mais est très très lent et comme j'apprends - apprécierait n'importe quelle aide sur comment je peux faire ce code plus rapidement. Je vous remercie.

    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

Essayez de fusionner toutes les Range à supprimer d'un objet MergeRng , puis supprimez-les toutes en même temps.

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

Que dis-tu de ça?

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

Vous pouvez supprimer votre code une seule fois et pas à chaque fois. Pour le faire comme ceci, essayez ceci:

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

Je n'ai pas essayé, mais ça devrait marcher.