如何提高VBA宏代码的速度？

Question

我没有太多编写宏的经验，因此需要此社区的帮助以解决遇到的以下问题：

我的宏将一个工作表中垂直范围内输入的值复制一份，然后粘贴这些值在另一个工作表中水平（转置）。它理论上会将第一张工作表中的值粘贴到第二张工作表中没有内容的第一行。由于前五行具有内容，所以它将这些值粘贴到第六行。 我在运行宏时遇到的问题是我觉得它太慢了，因此我希望它运行得更快。

我有相同的宏做同样的事情，但它将值粘贴到另一个工作表到第一行，它运行完美。

因此，我最好的猜测是第二个宏运行缓慢，因为它必须开始粘贴到第六行，并且前5行中可能有一些内容需要很长时间才能使宏经过（有很多单元格引用其他工作簿）来确定粘贴的下一行应该在哪里。这是我最好的猜测，因为我几乎不知道宏的任何信息，所以我不能确定问题是什么。

我在此向您提供我的宏的代码，并真诚地希望有人能告诉我什么使我的宏变慢，并为我提供解决方案，以便如何使它运行得更快。我在想，一个解决方案可能可能是宏不应该考虑前五行数据，并立即在第6行开始粘贴第一个条目。然后在第7行，等等。这可能是一个解决方案，但我不知道如何编写代码的方式，它会这样做。

感谢您抽出宝贵时间，帮助我找到一个解决办法，这里是代码：

Sub Macro1() 
Application.ScreenUpdating = False 

    Dim historyWks As Worksheet 
    Dim inputWks As Worksheet 

    Dim nextRow As Long 
    Dim oCol As Long 

    Dim myCopy As Range 
    Dim myTest As Range 

    Dim lRsp As Long 

    Set inputWks = wksPartsDataEntry 
    Set historyWks = Sheet11 

     'cells to copy from Input sheet - some contain formulas 
     Set myCopy = inputWks.Range("OrderEntry2") 

     With historyWks 
      nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row 
     End With 

     With inputWks 
      Set myTest = myCopy.Offset(0, 2) 

      If Application.Count(myTest) > 0 Then 
       MsgBox "Please fill in all the cells!" 
       Exit Sub 
      End If 
     End With 

     With historyWks 
      With .Cells(nextRow, "A") 
       .Value = Now 
       .NumberFormat = "mm/dd/yyyy hh:mm:ss" 
      End With 
      .Cells(nextRow, "B").Value = Application.UserName 
      oCol = 3 
      myCopy.Copy 
      .Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True 
      Application.CutCopyMode = False 
     End With 

     'clear input cells that contain constants 
     With inputWks 
     On Error Resume Next 
      With myCopy.Cells.SpecialCells(xlCellTypeConstants) 
       .ClearContents 
       Application.GoTo .Cells(1) ', Scroll:=True 
      End With 
     On Error GoTo 0 
     End With 

Application.ScreenUpdating = True 
End Sub 

Answer 1

只是重申已经取得的说：

Option Explicit 

Sub Macro1() 

'turn off as much background processes as possible 
With Excel.Application 
     .ScreenUpdating = False 
     .Calculation = Excel.xlCalculationManual 
     .EnableEvents = False 
End With 

    Dim historyWks As Excel.Worksheet 
    Dim inputWks As Excel.Worksheet 

    Dim nextRow As Long 
    Dim oCol As Long 

    Dim myCopy As Excel.Range 
    Dim myTest As Excel.Range 

    Dim lRsp As Long 

    Set inputWks = wksPartsDataEntry 
    Set historyWks = Sheet11 

     'cells to copy from Input sheet - some contain formulas 
     Set myCopy = inputWks.Range("OrderEntry2") 

     With historyWks 
      nextRow = .Cells(.Rows.Count, 1).End(Excel.xlUp).Offset(1, 0).Row 
     End With 

     With inputWks 
      Set myTest = myCopy.Offset(0, 2) 

      If Excel.Application.Count(myTest) > 0 Then 
       MsgBox "Please fill in all the cells!" 
       GoTo QuickExit 
      End If 
     End With 

     With historyWks 
      With .Cells(nextRow, 1) 
       .Value = Now 
       .NumberFormat = "mm/dd/yyyy hh:mm:ss" 
      End With 
      .Cells(nextRow, 2).Value = Excel.Application.UserName 
      oCol = 3 
      myCopy.Copy 
      .Cells(nextRow, 3).PasteSpecial Paste:=Excel.xlPasteValues, Transpose:=True 
      Excel.Application.CutCopyMode = False 
     End With 

     'clear input cells that contain constants 
     With inputWks 
     On Error Resume Next 
      With myCopy.Cells.SpecialCells(Excel.xlCellTypeConstants) 
       .ClearContents 
       Excel.Application.Goto .Cells(1) ', Scroll:=True 
      End With 
     On Error GoTo 0 
     End With 

    Calculate 

QuickExit 

With Excel.Application 
     .ScreenUpdating = True 
     .Calculation = Excel.xlAutomatic 
     .EnableEvents = True 
End With 

End Sub 

我会步宏行由行，试图找出哪条线路是缓慢的。

另一种选择 - 虽然不知道这是否会加快东西 - 是为了避免剪贴板，并失去了copy/paste所以你最好申请一个方法像下面来移动数据：

Option Explicit 

Sub WithoutPastespecial() 

'WORKING EXAMPLE 

Dim firstRange As Range 
Dim secondRange As Range 

Set firstRange = ThisWorkbook.Worksheets("Cut Sheet").Range("S4:S2000") 
With ThisWorkbook.Worksheets("Cutsheets") 
    Set secondRange = .Range("A" & .Rows.Count).End(Excel.xlUp).Offset(1) 
End With 

With firstRange 
     Set secondRange = secondRange.Resize(.Rows.Count, .Columns.Count) 
End With 
secondRange.Value = firstRange.Value 

End Sub 

Answer 2

请看看这篇文章也是如此。 How to speed up calculation and improve performance...

无论如何，Application.calculation = xlCalculationManual通常是罪魁祸首。但是我们可以注意到，易变的Excel工作表函数通常会在大规模的数据处理和功能方面杀死您的应用程序。

另外，对于您当前的代码，以下文章可能不直接相关。我发现它适用于所有Excel/VBA性能优化的提示。

75 Excel speeding up tips

PS：我没有足够的声誉在您的文章发表评论。所以添加为答案。

Answer 3

正如评论中的一些其他人所建议的，您应该将Application.Calculation更改为xlCalculationManual并记住最后将其设置回xlcalculationAutomatic。另外尝试设置Application.Screenupdating = False（并再次打开它）。另外，请记住.Copy是复制单元格值的非常低效的方法 - 如果您真的只需要这些值，请循环范围设置.Value到旧范围内的.Values。如果你需要所有的格式，你可能会停留在.Copy。

关闭计算/屏幕刷新标志时，请记住在任何情况下（即使程序在不同点退出或导致运行时错误）都将其重新打开。否则会发生各种不好的事情。:)

Answer 4

刚几点建议（会张贴评论，但我想我没有代表）：

1. 尝试指的细胞，而不是命名范围地址（怀疑这将是原因，但可能会造成一些打到性能）

2. 您的工作簿公式是否包含指向其他工作簿的链接？尝试在具有损坏的链接的文件上测试代码以查看它是否可以提高性能。

3. 如果这些都不是问题，我的猜测是如果公式过于复杂，可能会增加一些处理开销。尝试仅包含值的文件上的代码，以查看是否有任何改进的性能。

Answer 5

根据我的经验，提高性能的最佳方法是在代码中处理变量，而不是每次要查找值时访问电子表格。 将想要使用的任何范围保存在变量（变体）中，然后遍历它，就好像它是表单一样。有很多很多更快的读取速度数据（行，列） -

dim maxRows as double 
    dim maxCols as integer. 
    dim data as variant 
with someSheet 
    maxRows = .Cells(rows.count, 1).end(xlUp).row    'Max rows in sheet 
    maxCols = .Cells(1, columns.count).end(xlToLeft).column 'max columns in sheet 
    data = .Range(.Cells(1,1), .Cells(maxRows, maxCols))  'copy range in a variable 
end with 

从这里你可以访问数据的变量，如果它是像电子表格。

Answer 6

您可以通过在更改单元格值期间停止计算并在此之后启用它来提高速度。请点击链接。 http://webtech-training.blogspot.in/2013/10/how-to-stop-heavy-formula-calculation.html

Answer 7

.Cells（nextRow，3）.PasteSpecial粘贴：= xlPasteValues，移调：=真 Application.CutCopyMode =假

我不会那么做的。剪切，复制&粘贴操作是操作系统中处理器利用率最高的操作。

相反，你可以只从一个单元格/范围到另一个单元格/范围，指定值作为

Cells(1,1) = Cells(1,2) or Range("A1") = Range("B1") 

希望你有我的观点..