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

首先，避免选择工作表和单元格：Worksheets(i).Activate、Rows(j).Select。这是最耗时的。通常它可以用直接链接代替。

接下来，不要在j的循环中重复Worksheets(i).AutoFilterMode = False，在For j = 2 To lastrow之前重复一次就足够了。

第三，不要逐行复制。相反，复制整张纸：

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

Answer 2

请尝试此代码。它很快，主要在内存中工作，使用数组：

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