excel vba宏 合并多个sheet

科普：xls格式最多就65535行，xlsx格式最多是1048576行。

有时候办公室同事从系统上导出表，当数据量过大的时候，系统都会拆分成多个sheet来导出，每个sheet的表结构一致。
他们需要将sheet合并，这样以便做筛选，做透视表。

这里帮他们搞了个xlsm小工具，直接将一个工作簿中的多个sheet合并为1个。

小工具界面

打开文件，里边有操作表sheet以及结果表sheet。操作表是选择文件，或者填写一些合并的一些参数。
合并后的数据，显示在结果表sheet中。

当时他给我看的工作簿，有40+个sheet，每个sheet有6.5w行，总数就是266.5w条数据，由于单个sheet最多只能是104w条，只能建议他合并为3个sheet，再分别做透视表了。

sheet起点、终点，是指需要从第几个sheet作为起点，一路合并到终点sheet，这里填的是整数值，也可以不填。

造测试工作簿

新建了一个工作簿，里边两个sheet，数据内容如下图所示。

使用步骤

打开小工具，点击按钮，可以选择文件。我们选择刚刚造的工作簿。然后后台就开始合并了。

合并结束时，界面会弹框提示，左侧也会罗列一下相关信息。

合并的结果在结果表sheet中。

vba代码

Private Sub CommandButton1_Click()
Dim k
Dim start_pos As Integer
Dim end_pos As Integer


'清空sheet
Sheets("结果表").Range("A:ZZ").Clear
'选择文件
Dim filePath As String
filePath = getFile()
If filePath = "" Then Exit Sub

'获取参数
start_pos = ThisWorkbook.Sheets("操作表").Range("B7")
end_pos = ThisWorkbook.Sheets("操作表").Range("B8")
If start_pos > end_pos Then
    MsgBox ("起点比终点大？请检查。")
    Exit Sub
End If

'打开目标文件
Set k = Workbooks.Open(filePath)
Dim totalSheet As Integer
totalSheet = k.Sheets.Count


If start_pos <= 0 Then
    start_pos = 1
ElseIf start_pos > totalSheet Then
    start_pos = totalSheet
End If

If end_pos = 0 Then
    end_pos = totalSheet
ElseIf end_pos > totalSheet Then
    end_pos = totalSheet
End If

'遍历要合并sheet的工作簿
Dim cnt As Integer
cnt = 1
For Each sh In k.Sheets
    If cnt >= start_pos And cnt <= end_pos Then
        行 = ThisWorkbook.Sheets("结果表").Range("A1040000").End(xlUp).Row + 1
        sh.UsedRange.Copy ThisWorkbook.Sheets("结果表").Range("A" & 行)
    End If
    cnt = cnt + 1
Next
 
'关闭目标文件
k.Close SaveChanges:=False

'输出数据
ThisWorkbook.Sheets("操作表").Range("A5") = "文件名："
ThisWorkbook.Sheets("操作表").Range("A6") = "sheet总数："
ThisWorkbook.Sheets("操作表").Range("A7") = "sheet起点："
ThisWorkbook.Sheets("操作表").Range("A8") = "sheet终点："

ThisWorkbook.Sheets("操作表").Range("B5") = filePath
ThisWorkbook.Sheets("操作表").Range("B6") = totalSheet
ThisWorkbook.Sheets("操作表").Range("B7") = start_pos
ThisWorkbook.Sheets("操作表").Range("B8") = end_pos

MsgBox ("已生成，请检查，已复制文件" & filePath & "的第" & start_pos & "个至第" & end_pos & "个sheet")

End Sub


Function getFile()
'获取文件完整路径及文件名

'显示打开文件夹对话框
Set FileDialogObj = Application.FileDialog(msoFileDialogFilePicker)
With FileDialogObj
    .Title = "请选择文件"
    .AllowMultiSelect = False
End With

'选择文件
FileDialogObj.Show
If FileDialogObj.SelectedItems.Count > 0 Then
    getFile = FileDialogObj.SelectedItems(1)
Else
    getFile = ""
    MsgBox ("未选择文件")
End If

End Function

文件下载

xlsm下载链接