VBA中的高效循环

我已经写了一个VBAmacros的工作原理，但因为数据库也很大，所以耗时太长。 我知道这可以通过数组优化，但我不知道如何做到这一点。 有人可以帮我吗？

'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

我把你的代码和我的答案结合起来， 根据标准删除表macros中的行 ，我刚刚发布。 这是超快速的。 请查看我的其他答案的细节。

您可能需要调整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