Excelで行を削除する時間を最適化する

Question

1つの条件に基づいて1000/10000の行を削除したいが時間がかかり過ぎる。また、私は、この操作を行うには、より高速な方法を提案してください

などのタイマーを設定し、 Application.ScreenUpdating = False、

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 

をインターネット上で利用可能なすべてのソリューション、すなわちデータをフィルタ処理を試してみました。

Answer 1

これを試してみてください。行1を削除する代わりに、削除基準に適合するすべての行を見つけて、1回のヒットで削除します。ずっと効率的です。

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

この方法は高速です。

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