Объединение больших рабочих листов - самый быстрый / самый надежный метод?

Question

Я часто объединяю огромные рабочие листы в одну для целей отчетности.

У меня часто возникают проблемы с нехваткой макросов, отказом работать, блокировкой ПК и т. Д.

Поиск на этом сайтеЯ неоднократно заявлял, что копирование / вставка - это более медленный метод перемещения больших наборов данных.

Однако, когда я попробовал эти два разных подхода, копировать / вставить был быстрее (я даже пытался отключить обновления экрана!)

Как получается, что dest = src выигрывает?Я думал, потому что это избегало использования функций уровня приложения, это было бы быстрее.(Я также должен был вставить эти листы (i). Активируйте детали, чтобы заставить работать переменные диапазона.)

Я тестировал с 5 рабочими листами по 60 тыс. Строк и 49 столбцами.Код 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У папы улучшенный код копирования / вставки.

копирование / вставка - 10,6 секунды
dest = src -> 120 секунд

Так что для объединения листов по крайней мере, копировать /паста, кажется, давит.

Answer 1

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

Answer 2

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

Я думаю, вы могли бы найти этот подход немного быстрее