Optimieren der Zeit zum Löschen von Zeilen in Excel VBA

Question

Ich möchte einige Zeilen löschen - 1000/10000 basierend auf einer Bedingung, aber es dauert zu lange dauern. Ich habe auch versucht, all verfügbaren Lösungen im Internet heißt die Daten filtert, Application.ScreenUpdating = False, Einstellung Timer usw.

Private Sub Remove_incomplete_records_Click() 
Dim n, count As Integer 
Dim i As Long 
Dim lastrownum As Integer 

lastrownum = Sheets("Master_Data").Cells(Rows.count, 1).End(xlUp).Row 

Dim varCalcmode 

Do While (lastrownum) 
    Application.ScreenUpdating = False  
    'for NB,FO etc if field your refernence is not present then delete the entire row.  
    For i = 2 To lastrownum  
     If (Sheets("Master_Data").Cells(i, 2).Value <> "YC" And Sheets("Master_Data").Cells(i, 2).Value <> "YK" And Sheets("Master_Data").Cells(i, 2).Value <> "MK" And Cells(i, 2).Value <> "WK" And Sheets("Master_Data").Cells(i, 2).Value <> "AN") Then 
      If (Sheets("Master_Data").Cells(i, 4).Value = "") Then 
       On Error Resume Next 
       Sheets("Master_Data").Rows(i).EntireRow.Delete Shift:=xlUp 
       varCalcmode = Application.Calculation 
       Application.Calculation = xlCalculationManual 
       Application.ScreenUpdating = False 
      Else 
      End If 
     Else 
     End If 
    Next i 
Loop 

Application.Calculation = varCalcmode 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

End Sub 

Bitte legen nahe, den schnellen Weg, um diese Operation zu tun.

Answer 1

Versuchen Sie es stattdessen. Anstatt die Zeilen 1 bis 1 zu löschen, findet sie jede Zeile, die zu den Löschkriterien passt, und löscht sie in einem Treffer. Viel effizienter

Private Sub Remove_incomplete_records_Click() 
    Dim i As Long, LastRowNum As Long 
    Dim DeleteRng As Range 
    Dim varCalcmode As XlCalculation 

    With Application 
     .ScreenUpdating = False 
     varCalcmode = .Calculation 
     .Calculation = xlCalculationManual 
    End With 

    With Sheets("Master_Data") 
     LastRowNum = .Cells(Rows.count, 1).End(xlUp).Row 

     'for NB,FO etc if field your refernence is not present then delete the entire row. 
     For i = 2 To LastRowNum 

       If .Cells(i, 2).Value2 <> "YC" And .Cells(i, 2).Value2 <> "YK" And _ 
        .Cells(i, 2).Value2 <> "MK" And Cells(i, 2).Value2 <> "WK" And _ 
        .Cells(i, 2).Value2 <> "AN" And .Cells(i, 4).Value2 = vbNullString Then 
         If DeleteRng Is Nothing Then 
          Set DeleteRng = Sheets("Master_Data").Rows(i) 
         Else 
          Set DeleteRng = Union(DeleteRng, shets("Master_Data").Row(i)) 
         End If 
        End If 
       End If 
     Next i 
    End With 

    If Not DeleteRng Is Nothing Then DeleteRng.EntireRow.Delete Shift:=xlUp 

    With Application 
     .Calculation = varCalcmode 
     .ScreenUpdating = True 
    End With 
End Sub 

Answer 2

diese Methode ist schneller.

Private Sub Remove_incomplete_records_Click() 
Dim n, count As Integer 
Dim i As Long 
Dim lastrownum As Integer 
Dim rngU As Range 

    lastrownum = Sheets("Master_Data").Cells(Rows.count, 1).End(xlUp).Row 

    Dim varCalcmode 
    Application.ScreenUpdating = False 

    Do While (lastrownum) 

     'for NB,FO etc if field your refernence is not present then delete the entire row. 
     For i = 2 To lastrownum 
      If (Sheets("Master_Data").Cells(i, 2).Value <> "YC" And Sheets("Master_Data").Cells(i, 2).Value <> "YK" And Sheets("Master_Data").Cells(i, 2).Value <> "MK" And Cells(i, 2).Value <> "WK" And Sheets("Master_Data").Cells(i, 2).Value <> "AN") Then 
       If (Sheets("Master_Data").Cells(i, 4).Value = "") Then 
        'On Error Resume Next 
        With Sheets("Master_Data") 
         If rngU Is Nothing Then 
          Set rngU = .Range("a" & i) 
         Else 
          Set rngU = Union(rngU, .Range("a" & i)) 
         End If 
        End With 
        'Sheets("Master_Data").Rows(i).EntireRow.Delete Shift:=xlUp 
        'varCalcmode = Application.Calculation 
        'Application.Calculation = xlCalculationManual 
        'Application.ScreenUpdating = False 
       Else 
       End If 
      Else 
      End If 
     Next i 
    Loop 
    rngU.EntireRow.Delete 
    'Application.Calculation = varCalcmode 
    'Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 

End Sub