VBAの効率的なループ

Question

私はVBAマクロを書いていますが、データベースも非常に大きいので時間がかかりすぎます。 これは配列を使って最適化することができますが、どのように作成するのか分かりません。 誰かが私を助けてくれますか？

'Identify how many rows are in the file 
finalrow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row 

'fill the empty fields which requires the part number and description 
For i = 2 To finalrow 
    If Cells(i, 3) = 0 Or Cells(i, 3) = "------------" Or Cells(i, 3) = "e" Or Cells(i, 3) = "111)" Or Cells(i, 3) = "ion" Then 
     If Cells(i, 4) = 0 Or Cells(i, 4) = "-----------" Or Cells(i, 4) = "Location" Then 
      Range("A" & i & ":H" & i).Select 
      Selection.Delete Shift:=xlUp 
      i = i - 1 
      Else 
       For j = 1 To 3 
        Cells(i, j) = Cells(i - 1, j) 
       Next 
     End If 
    End If 
    If Cells(i, 1) = 0 Then 
     Cells(i, 1) = Cells(i - 1, 1) 
    End If 

    If Cells(i, 4) = 0 Then 
      Range("A" & i & ":H" & i).Select 
      Selection.Delete Shift:=xlUp 
      i = i - 1 
    End If 

    Count = Count + 1 
    If Count = finalrow Then 
     i = finalrow 
    End If 
Next 

Answer 1

は、私はちょうど投稿を終えたことを、excel Delete rows from table Macro based on criteriaに私の答えとあなたのコードを組み合わせました。超高速です。詳細については私の他の答えをチェックしてください。

Targetの範囲を調整する必要がある場合があります。データがA1から始まり、それが動作するはずの完全な空白行がない場合。

Sub DeleteRows() 
    Dim Start: Start = Timer 
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 

    Const PreserveFormulas As Boolean = True 
    Dim Target As Range 
    Dim DeleteRow As Boolean 
    Dim Data, Formulas, NewData 
    Dim pos As Long, x As Long, y As Long 
    Set Target = Range("A1").CurrentRegion 
    Data = Target.Value 

    If PreserveFormulas Then Formulas = Target.Formula 

    ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2)) 

    For x = 2 To UBound(Data, 1) 
     DeleteRow = True 

     If Data(x, 3) = 0 Or Data(x, 3) = "------------" Or Data(x, 3) = "e" Or Data(x, 3) = "111)" Or Data(x, 3) = "ion" Then 
      If Data(x, 4) = 0 Or Data(x, 4) = "-----------" Or Data(x, 4) = "Location" Then 
       DeleteRow = False 
      End If 
     End If 

     If Data(x, 4) = 0 Or Data(x, 4) = "-----------" Or Data(x, 4) = "Location" Then DeleteRow = False 

     If Not DeleteRow Then 
      pos = pos + 1 
      For y = 1 To UBound(Data, 2) 
       If PreserveFormulas Then 
        NewData(pos, y) = Formulas(x, y) 
       Else 
        NewData(pos, y) = Data(x, y) 
       End If 
      Next 
     End If 
    Next 
    Target.Formula = NewData 


    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 

    Debug.Print "Execution Time: "; Timer - Start; " Second(s)" 
End Sub 

Answer 2

私はこれを単に起動したい：

'Identify how many rows are in the file 
finalrow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row 

'fill the empty fields which requires the part number and description 
For i = 2 To finalrow 
    Set ci3 = Cells(i, 3) 

    If ci3 = 0 Or ci3 = "------------" Or ci3 = "e" Or ci3 = "111)" Or ci3 = "ion" Then 
     Set ci4 = Cells(i, 4) 

     If ci4 = 0 Or ci4 = "-----------" Or ci4 = "Location" Then 
      Range("A" & i & ":H" & i).Select 
      Selection.Delete Shift:=xlUp 
      i = i - 1 
      Else 
       For j = 1 To 3 
        Cells(i, j) = Cells(i - 1, j) 
       Next 
     End If 
    End If 
    If Cells(i, 1) = 0 Then 
     Cells(i, 1) = Cells(i - 1, 1) 
    End If 

    If Cells(i, 4) = 0 Then 
      Range("A" & i & ":H" & i).Select 
      Selection.Delete Shift:=xlUp 
      i = i - 1 
    End If 

    Count = Count + 1 
    If Count = finalrow Then 
     i = finalrow 
    End If 
Next