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

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

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

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

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

Я тестировал 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 Dad.

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

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

0
HotSauceCoconuts 17 Дек 2018 в 18:27

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

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

1
Harassed Dad 17 Дек 2018 в 15:56
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
1
user10798192user10798192 17 Дек 2018 в 17:10