VBA для настройки области диапазона / печати при консолидации основного листа

Question

У меня есть этот код VBA, который используется для объединения разных вкладок на одном листе. Теперь проблема в том, что копирование каждой отдельной позиции на один лист занимает слишком много времени. Нужно обновить, чтобы я мог установить область печати в качестве диапазона и скопировать листы обратно на один.

 ActiveWorkbook.Worksheets("Master Sheet").Activate
    Rows("2:" & Rows.Count).Cells.ClearContents

    totalsheets = Worksheets.Count
    For i = 1 To totalsheets

    If Worksheets(i).Name <> "Master Sheet"  Then
    lastrow = Worksheets(i).Cells(Rows.Count, 1).End(xlUp).Row


            For j = 2 To lastrow

            Worksheets(i).Activate
            Worksheets(i).AutoFilterMode = False
            Worksheets(i).Rows(j).Select
            Selection.Copy
            Worksheets("Master Sheet").Activate                               

            lastrow = Worksheets("Master Sheet").Cells(Rows.Count, 1).End(xlUp).Row

            Worksheets("Master Sheet").Cells(lastrow + 1, 1).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False

            Next
            End If
            Next
            MsgBox "Completed"
            ActiveWorkbook.Save
End Sub

Answer 1

Попробуйте этот код, пожалуйста. Это быстро, работает в основном в памяти, используя массивы:

    Sub testConsolidate()
       Dim sh As Worksheet, shM As Worksheet, lastRowM As Long, arrUR As Variant

        Set shM = ActiveWorkbook.Worksheets("Master Sheet")
        shM.Rows("2:" & Rows.Count).Cells.Clear

        For Each sh In ActiveWorkbook.Worksheets
            If sh.Name <> "Master Sheet" Then
                sh.AutoFilterMode = False
                lastRowM = shM.Cells(Cells.Rows.Count, 1).End(xlUp).row
                arrUR = sh.UsedRange.Offset(1).value 'copy from row 2 down
                shM.Cells(lastRowM + 1, 1).Resize(UBound(arrUR, 1), _
                                            UBound(arrUR, 2)).value = arrUR
            End If
        Next
        MsgBox "Completed"
        ActiveWorkbook.Save
    End Sub

Answer 2

Прежде всего, избегайте выбора таблиц и ячеек: Worksheets(i).Activate, Rows(j).Select. Это самый трудоемкий. Обычно его можно заменить прямыми ссылками.

Далее, не повторяйте Worksheets(i).AutoFilterMode = False внутри l oop для j, достаточно будет сделать это один раз до For j = 2 To lastrow.

В-третьих, не копируйте построчно. Вместо этого скопируйте весь лист:

Dim lastCell As Range
Set lastCell = Sheets("Sheet1").Range("A1").SpecialCells(xlLastCell)
Sheets("Sheet1").Range(Range("A1"), lastCell).Copy