如何提高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

根据我的经验，提高性能的最佳方法是处理代码中的变量，而不是每次要查找值时都访问电子表格。 将您要使用的任何范围保存在变量（变体）中，然后像工作表一样遍历它。

    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

从这里您可以像访问电子表格一样访问数据变量 - data(row, column) 读取速度快得多。

Answer 3

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

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

另外，对于您当前的代码，以下帖子可能不直接相关。我发现它对于有关整体 Excel/VBA 性能优化的提示很有用。

75 Excel speeding up tips

PS：我没有足够的声誉来评论你的帖子。所以添加为答案..

Answer 4

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

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

Answer 5

只是一些建议（本来可以作为评论发布，但我想我没有代表）：

1. 尝试引用单元格地址而不是命名范围（怀疑这是原因，但可能会对性能造成一些影响）

2. 您的工作簿公式是否包含指向其他工作簿的链接？尝试在链接断开的文件上测试代码，看看它是否能提高性能。

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

Answer 6

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

Answer 7

.Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True Application.CutCopyMode = False

我不会那样做。就处理器利用率而言，在操作系统中，剪切、复制和粘贴操作是成本最高的操作。

相反，您可以将一个单元格/范围内的值分配给另一个单元格/范围，如

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

希望你明白我的意思..