将工作簿中的所有 Excel 选项卡合并到另一个工作簿上的最小选项卡中

Question

我在 1 个工作簿中有 200 张工作表，每张工作表平均有 65,000 条记录。我正在尝试构建一个宏，将 1 个 Excel 文件中的所有工作表合并为新 Excel 文件中的最小工作表数。由于 Excel 有 1.xxx 万条记录的限制，因此新文件必须有 1 张以上的表格，但我希望在新文件/选项卡上尽可能多地合并。

以下是我迄今为止构建的内容，但我什至很难正确复制和过去数据，更不用说在需要时添加新工作表了。 有人可以帮忙吗？

Sub Combine()
Dim J As Integer
Dim s As Worksheet


Dim wb As Workbook
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Sheets(1).Select

'Opens initial file
strFile = Application.GetOpenFilename
Workbooks.Open strFile
Set INITIALFILE = ActiveWorkbook


' copy headings
Sheets(1).Activate
Range("A1").EntireRow.Select
Selection.Copy
wb.Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A" & Sheets(1).Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial

INITIALFILE.Activate
For Each s In ActiveWorkbook.Sheets
    If s.Name <> "Combined" Then
        Application.GoTo Sheets(s.Name).[a1]
        Selection.CurrentRegion.Select
        ' Don't copy the headings
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy
wb.Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A" & Sheets(1).Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
INITIALFILE.Activate
End If
Next
End Sub

Answer 1

如果你使用Range 对象变量，你很少需要使用Select 并且你的屏幕会安静很多。如前所述，使用一般的On Error Resume Next 将使您的代码几乎不可能正常工作，因为您不会看到有用的错误消息。

Sub Combine()
Dim NewFile As Workbook
Dim InitialFile As Workbook
Const RowLimit As Long = 1000000

Dim strFile As String
Dim InRows As Long
Dim OutRows As Long
Dim FirstSheet As Worksheet
Dim OutSheet As Worksheet
Dim ASheet As Worksheet
Dim CopySet As Range
Dim OutLoc As Range
Dim Anon As Variant

Set NewFile = ActiveWorkbook
Set FirstSheet = NewFile.Sheets.Add(After:=Sheets(Sheets.Count))
Set OutSheet = FirstSheet
Set OutLoc = OutSheet.Range("A1")

'Opens initial file
strFile = Application.GetOpenFilename
Workbooks.Open strFile
Set InitialFile = ActiveWorkbook

OutSheet.Activate

For Each ASheet In InitialFile.Sheets
    Anon = DoEvents()
    If ASheet.Name <> "Combined" Then
        Set CopySet = ASheet.Cells.SpecialCells(xlCellTypeLastCell)
        If CopySet.Row + OutLoc.Row > RowLimit Then
            Set OutSheet = NewFile.Sheets.Add(After:=OutSheet)
            Set OutLoc = OutSheet.Range("A1")
        End If
        ' Only copy the headings if needed
        If OutLoc.Row = 1 Then
            Set CopySet = Range(ASheet.Range("A1"), CopySet)
        Else
            Set CopySet = Range(ASheet.Range("A2"), CopySet)
        End If
        CopySet.Copy OutLoc
        Set OutLoc = OutLoc.Offset(CopySet.Rows.Count, 0)
    End If
Next ASheet

FirstSheet.Activate

End Sub

对DoEvents() 的调用是为了使屏幕保持最新状态，而不是以某种半画的方式冻结。