时间戳

首页 > 解决方案 > 合并大型工作表 - 最快/最可靠的方法？

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

问题描述

我经常将巨大的工作表合并为一个用于报告目的。

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

搜索该站点时，我多次看到它指出复制/粘贴是转移大数据集的一种较慢的方法。

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

dest = src表现如何？我认为因为它避免使用应用程序级别的功能，它会更快。（我还必须放入那些 Sheet(i).Activate 部分以使范围变量起作用。）

我测试了 5 个大约 60k 行和 49 列的工作表。复制/粘贴代码大约需要 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 =源代码：

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

编辑1：

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

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

因此，至少对于组合工作表，复制/粘贴似乎正在粉碎它。

标签： excelvbaoptimization

解决方案

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

推荐阅读