使VBA脚本运行更快

这是我第一次在ExcelVBA中查找数据集中与集群中的另一个条目包含相同地址的行。必须合并这些条目，然后删除该行。我提出了以下方法，这些方法很有效（从我对小样本的测试中可以看出）：

我面临的问题是时间。在大约50行的小样本上进行测试需要5分钟。我的条目总共超过10万行。它已经跑了一天多，看不到尽头。有没有办法优化这个，这样我就不必等到我变灰了

亲切问候,

---

Rob

我在评论中提到了两件事：

1） 删除

k

（以及整个

k=k+1

行）；替换为

j

。同时将

行（i+1）.EntireRow.Delete

替换为

行（i+j）.EntireRow.Delete

2） 由于您正在删除行，

lastrow

在到达时实际上是空的。而不是最后一行的

i=2

，而是让它在单元格（i，12）时执行“或其他操作。这导致它在一堆空行上循环

---

此外，使用数据透视表，或者如注释中所述，使用SQL

GROUP BY

可以更轻松地进行这些类型的汇总。您是否有在单元格中计算的内容？如果是这样，将这些行分别放在顶部和底部可能会有所帮助：

Application.Calculation=xlManual

和

Application.Calculation=xlAutomatic

我假设

/

是您为此添加的注释，而不是代码本身？（因为

“

是VBA的注释标记）。如果使用

F8

单步执行代码，循环似乎卡在哪里？还可能在循环的每个部分添加一些中断，以帮助确定循环在哪些方面花费的时间比预期的要多。如果您的代码按预期工作（除了性能之外-使用一个小数据集进行测试），那么请求反馈和优化提示的最佳位置是，不是。您的问题将是由于当y和x循环继续“永远”时，如果

单元格（i，9）

或

单元格（i，12）

为

空

（当

i

到达一个完全空的行时会发生这种情况，这是因为您正在删除行，但仍然循环到删除任何内容之前的最后一个行号）。您可以尝试将i=lastrow的循环更改为

，改为2步骤-1

。我还没有对您正在做的事情进行足够的分析，以确定这是否会给您带来任何其他问题，但它应该可以消除与空单元格进行比较所导致的问题。或者您也可以只添加一条语句，说明

If IsEmpty（单元格（i，“a”））然后在i=2 To lastrow语句之后立即退出For

。

Sub Merge_Orders()

Application.ScreenUpdating = False
Application.DisplayStatusBar = False

Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim y As Long
Dim x As Long
Dim j As Long
Dim k As Long

For i = 2 To lastrow //for each row, starting below header row
  j = 1
  y = (Cells(i, 9)) //this is the clusternumber
  Do While y = (Cells(i + j, 9)) //while the next row is in the same cluster
    x = (Cells(i, 12)) //this is the adresscode
    k = 1
    Do While x = (Cells(i + k, 12)) //while the current adresscode is the same as the next, iterating until another adresscode is hit
      Cells(i, 16) = Val(Cells(i, 16)) + Val(Cells(i + k, 16)) //update cell value
      Cells(i, 18) = Cells(i, 18) + Cells(i + k, 18)  //update cell value
      Cells(i, 19) = Cells(i, 19) + Cells(i + k, 19)  //update cell value
      If Cells(i, 20) > Cells(i + k, 20) Then
        Cells(i, 20) = Cells(i + k, 20)  //update cell value
      End If
      If Cells(i, 21) > Cells(i + k, 21) Then
        Cells(i, 21) = Cells(i + k, 21)  //update cell value
      End If
      Cells(i, 22) = Cells(i, 22) + Cells(i + k, 22)  //update cell value
      Cells(i, 23) = Cells(i, 23) + Cells(i + k, 23)  //update cell value

      Rows(i + 1).EntireRow.Delete //Delete the row from which data was pulled
      k = k + 1
    Loop
    j = j + 1
  Loop
Next i

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub