Question

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

需要合并的工作表数量各不相同 - 大约6到40张工作表。我通过在＆＃34; Src＆＃34;
同一工作簿中有大约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代码在执行时被解释，并且本质上比预编译代码慢。而且，它比手工操作还要快得多！

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

2 个答案: