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

Question

我没有太多编写宏的经验,因此需要这个社区的帮助来解决以下问题:

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

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

因此,我最好的猜测是第二个宏运行缓慢,因为它必须在第六行开始粘贴,前五行可能会有一些内容花费大量时间让宏通过(有很多单元格引用其他工作簿)以确定下一行的粘贴位置.这是我最好的猜测,因为我几乎不知道宏,我不能肯定问题是什么.

我特此向您提供宏的代码,并真诚地希望有人能告诉我是什么让我的宏变慢,并为我提供了如何让它运行得更快的解决方案.我认为一个解决方案可能是宏可能不应该考虑前五行数据并立即开始在第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

从这里您可以访问数据变量,就像电子表格一样 - 数据(行,列),读取速度更快.

Answer 3

请看一下这篇文章. 如何加快计算速度和提高绩效......

无论如何,Application.calculation = xlCalculationManual通常是罪魁祸首.但是我们可以注意到,易变的Excel工作表函数可能会在大规模的数据处理和功能方面大部分时间都会导致应用程

此外,对于您当前的代码,后面的帖子可能不是直接相关的.我发现它对于整体Excel/VBA性能优化的提示非常有用.

75 Excel加速提示

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