有没有更快的方法来执行这个 VBA 宏？

Question

我正在尝试将 Excel 中的多个工作表合并为 1 个工作表。我使用合并的工作表在同一个工作簿中运行一组报告。

• 需要合并的工作表数量各不相同 - 大约 6 到 40 个工作表。我通过在它们前面加上“Src”来标识要合并的工作表
• 在同一个工作簿中还有大约 40 个其他电子表格（根据合并工作表和其他计算得出的报告）
• 要合并的每个工作表的格式相同

我是宏的新手，所以在互联网上找到了一些代码来自动整合，但是当我有 12 个左右的工作表需要整合时，它的运行速度非常慢。

无论如何我可以加快这个宏的速度吗？

Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

' Clear the consol worksheet except the top row with the headings
Set DestSh = ActiveWorkbook.Worksheets("All Data")
DestSh.Rows("5:" & Rows.Count).ClearContents


' Fill in the start row.ie the row in each of the source sheets that contain the data (do not include heading rows)
StartRow = 5

' Loop through all worksheets and copy the data to the
' summary worksheet if worksheet name starts with src.
For Each sh In ActiveWorkbook.Worksheets
    If LCase(Left(sh.Name, 3)) = "src" Then

        ' Find the last row with data on the summary
        ' and source worksheets.
        Last = LastRow(DestSh)
        shLast = LastRow(sh)

        ' If source worksheet is not empty and if the last
        ' row >= StartRow, copy the range.
        If shLast > 0 And shLast >= StartRow Then
            'Set the range that you want to copy
            Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

           ' Test to see whether there are enough rows in the summary
           ' worksheet to copy all the data.
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
               MsgBox "There are not enough rows in the " & _
               "summary worksheet to place the data."
               GoTo ExitTheSub
            End If

            ' This statement copies values, and formats.
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

        End If

    End If
Next


ExitTheSub:
Application.GoTo DestSh.Cells(1)

' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
On Error GoTo 0
End Function

Answer 1

假设您有一列从头到尾没有空白行，请尝试将LastRow() 函数替换为

Function LastRow(sh As Worksheet)
Dim i as Long, R as Range

    i = 1
    Set R = sh.[A1]

    Do while R(i,1) <> ""    ' we asume column A (.. 1) here
        i = i+1
    Loop

    LastRow = i

End Function

或者，您可以使用.CurrentRegion 属性来避免将行和列一起计算。

Answer 2

替换：

Last = LastRow(DestSh)
shLast = LastRow(sh)

与

Last = DestSh.UsedRange.Rows.Count
shLast = sh.UsedRange.Rows.Count

您有一个LastCol(sh) 函数，但我实际上并没有看到对它的调用。如果我错过了，您可以将函数调用替换为：

sh.UsedRange.Columns.Count

通常，粘贴会复制值和格式，因此，除非您特别想避免某些事情，否则请替换：

With DestSh.Cells(Last + 1, "A")
  .PasteSpecial xlPasteValues
  .PasteSpecial xlPasteFormats
  Application.CutCopyMode = False
End With

与

DestSh.Cells(Last + 1, "A").Paste
Application.CutCopyMode = False

最后，请记住，VBA 代码在执行时被解释，并且本质上会比预编译代码慢。而且，它仍然比手工操作要快得多！