VBAmacros运行时间太长

我已经写了几个子，然后从一个主要的子被调用。 单独的子系统运行速度非常快，大多数是瞬时的（DoFind子系统由于表中有大量的数据需要花费几秒钟的时间），但是当我运行主子系统时，需要一分钟的时间来执行。 任何想法/提示为什么是这种情况？

请注意，我还没有太多的VBA经验（所有这些都是在过去一周中学到的）。 还有其他的macros使用，但他们没有显示，因为即使testing子约1分钟

Sub DoFind() Dim i As Long i = 1 Do While Sheets("Temp").Cells(i, "A").Value <> Empty Dim BearingArray(6) As String BearingArray(0) = Sheets("Temp").Cells(i, "A").Value BearingArray(1) = Sheets("Temp").Cells(i, "B").Value BearingArray(2) = Sheets("Temp").Cells(i, "C").Value BearingArray(3) = Sheets("Temp").Cells(i, "D").Value BearingArray(4) = Sheets("Temp").Cells(i, "E").Value BearingArray(5) = Sheets("Temp").Cells(i, "F").Value BearingArray(6) = Sheets("Temp").Cells(i, "G").Value With Sheets("Calculations") .Cells(17, "K").Value = BearingArray(0) .Cells(19, "O").Value = BearingArray(1) .Cells(20, "O").Value = BearingArray(2) .Cells(23, "O").Value = BearingArray(3) .Cells(22, "O").Value = BearingArray(4) .Cells(26, "O").Value = BearingArray(5) .Cells(17, "L").Value = BearingArray(6) End With i = i + 1 If Sheets("Calculations").Cells(17, "M").Value = "PASS" Then Exit Do Else End If Loop If Sheets("Temp").Cells(i, "A").Value = Empty Then MsgBox "No available bearing." End If End Sub 

---

 Sub Create_Sheet_Temp() ThisWorkbook.Sheets.Add ActiveSheet.Name = "Temp" ' This creates a new worksheet called "Temp" End Sub 

---

 Sub Copy_Paste() Dim NewTable As ListObject Sheets("Calculations").Activate Set NewTable = Sheets("Calculations").ListObjects("Full_Bearings_List") NewTable.Range.SpecialCells(xlCellTypeVisible).Select NewTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy Sheets("Temp").Range("A1").PasteSpecial xlPasteAll Application.CutCopyMode = False 'This sub copies all visible cells from a filtered table and pastes them to the new sheet called "Temp" End Sub 

---

 Sub test() Create_Sheet_Temp Copy_Paste DoFind End Sub 

Answer 1

您可以通过将工作表存储在variables中（循环之前）来加速代码。

 Dim TempWS as Worksheet Dim CalcWS as Worksheet set tempws= Sheets("Temp") set CalcWS=Sheets("Calculations") 

还要在循环之外声明数组。 此外，Idbuild议使用数字列索引。

 Sheets("Temp").Cells(i, "G").Value 

到TempWS.Cells（i，7）.Value

与空比较并不总是最好的select，尝试

 ... <> "" 

编辑：对于复制尝试使用复制方法的目标参数。 帮助中的示例：

 Worksheets("Sheet1").Range("A1:D4").Copy _ destination:=Worksheets("Sheet2").Range("E5")