Question

我经常将庞大的工作表合并为一个报表。

我经常遇到宏内存不足，拒绝工作，锁定PC等问题。

在此站点上搜索我发现它多次表明复制/粘贴是一种用于移动大量数据的慢速方法。

但是，当我尝试这两种不同的方法时，复制/粘贴会更快（我什至尝试禁用屏幕更新！）

dest = src 的表现如何？我认为因为避免使用应用程序级功能会更快。（我还必须放入那些Sheet（i）。激活零件以使范围变量起作用。）

我用大约60k行和49列的5个工作表进行了测试。 copy / paste 代码将其钉在30秒内，而 dest = src 似乎需要90秒。

此外，我已经读过有关使用动态数组以这种方式复制数据的信息，但是我从未使它起作用。

复制/粘贴代码：

Sub Combine()
    Dim J As Integer
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = "Combined"
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    For J = 2 To Sheets.Count
        lastRow = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row
        Sheets(J).Activate
        Range("A1").Select
        Selection.CurrentRegion.Select
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        Selection.Copy Destination:=Sheets(1).Range("A" & lastRow + 1)
    Next
End Sub

dest = src 代码：

Sub collateSheets()

    Dim ws As Worksheet
    Dim LR As Long, LR2 As Long
    Dim LC As Long
    Dim i As Long
    Dim src As Range
    Dim dest As Range

    startNoUpdates

    Set ws = Worksheets.Add(before:=Sheets(1)) ' place new sheet in first position
    With ws
        .Name = "Collated Data"
        .Range("1:1").Value = Sheets(2).Range("1:1").Value
    End With
    On Error GoTo skip
    For i = 2 To Worksheets.Count ' avoiding "Collated Data"
        With Sheets(i)
            LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        End With
        LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        LR2 = Sheets(i).Cells(Sheets(i).Rows.Count, 1).End(xlUp).Row
        Sheets(i).Activate
        Set src = Sheets(i).Range(Cells(2, 1), Cells(LR2, LC))
        Sheets(1).Activate
        Set dest = Sheets(1).Range(Cells(LR + 1, 1), Cells(LR + LR2 - 1, LC))
        dest.Value = src.Value
skip:
    Next

    endNoUpdates

End Sub

Sub startNoUpdates()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With
End Sub

Sub endNoUpdates()
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With
End Sub

EDIT1：

我尝试了user10798192看起来非常复杂的代码（什么是IIf？）和Harassed Dad改进的复制/粘贴代码。

复制/粘贴-10.6秒
dest = src-> 120秒

因此，至少要合并表格，复制/粘贴似乎会压碎它。

Answer 1

Sub Demo()
 'generic aggregate all sheets into 1 routine
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 On Error GoTo whoops
 Dim ws As Worksheet
 Dim dest As Worksheet
 Dim source As Range
 Dim Target As Range
 Set dest = Worksheets.Add()
 Set Target = dest.Range("a1")
 Worksheets(1).Range("a1").EntireRow.Copy Target
 Set Target = Target.Offset(1, 0)
 For Each ws In Worksheets
     If ws.Index <> 1 Then
        ws.UsedRange.Copy Target
        Set Target = dest.Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
      End If
 Next ws
 whoops:
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 MsgBox "Done"
 End Sub

我认为您可能会发现这种方法更快

Answer 2

Option Explicit

Sub collateSheets()

    Dim ws As Worksheet, w As Long

    alterEnvironment restore:=False

    Set ws = Worksheets.Add(before:=Sheets(1))
    With ws
        .Name = "Collated Data"
        .Range("1:1").Value = Sheets(2).Range("1:1").Value
    End With

    On Error GoTo skip
    For w = 2 To Worksheets.Count
        With Worksheets(w).Cells(1).CurrentRegion.Offset(1)
            Worksheets(1).Cells(.Rows.Count, "A").End(xlUp). _
                Offset(1).Resize(.Rows.Count, .Columns.Count) = .Value
        End With
skip:
    Next w

    alterEnvironment

End Sub

Sub alterEnvironment(Optional restore As Boolean = True)

    Static origCalc As Variant

    With Application
        If IsEmpty(origCalc) Then origCalc = .Calculation
        .Calculation = IIf(restore, origCalc, xlCalculationManual)
        .ScreenUpdating = restore
        .EnableEvents = restore
        .DisplayAlerts = restore
    End With

End Sub

合并大型工作表-最快/最可靠的方法？

2 个答案: