将多个EXCEL工作簿合并为同一个工作簿的多个不用工作表代码

[无爱的人无所畏惧]

各位大佬好，我在网上搜了一段代码，作用是：将多个EXCEL工作簿合并为同一个工作簿的多个不用工作表。第一批表格输入代码时完全正常，达到了效果，但在第二批表输入代码时显示下标越界，我对这方面完全小白，代码也是网上搜的，因为表格量非常大，所以我无从下手，望各位大佬帮我解决一下，这是部分表格以及代码的百度网盘链接，链接: https://pan.baidu.com/s/19fmnTObzB6XoAcEhjV042w 提取码: iu4c
如果大佬不想上链接，这是代码截图
这是表格截图，共有62个这样的表格

[VB业余爱好者]

看了一下，因为你要复制的那些文件中中宏代码，而且是一打开就运行，下标越界不是当前代码下标越界，而是那些文件中有下标越界的地方

[VB业余爱好者]

看，这是你52-2.xls中的代码，

[nangongxiaobai]

我很好奇你是如何两次都把不同打错成不用的。

[hzg303]

最后解决完了？

[ffon123]

孙老师代码 试试


Sub CollectWorkBookDatas()
Dim shtActive As Worksheet, rng As Range, shtData As Worksheet
Dim nTitleRow As Long, k As Long, nLastRow As Long
Dim i As Long, j As Long, nStartRow As Long
Dim aData, aResult, nStarRng As Long
Dim strPath As String, strFileName As String
Dim strKey As String, nShtCount As Long
With Application.FileDialog(msoFileDialogFolderPicker)
'取得用户选择的文件夹路径
If .Show Then strPath = .SelectedItems(1) Else Exit Sub
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strKey = InputBox("请输入需要合并的工作表所包含的关键词：" & vbCrLf & "如未填写关键词，则默认汇总全部表格数据", "提醒")
If StrPtr(strKey) = 0 Then Exit Sub '如果点击了取消或者关闭按钮，则退出程序
nTitleRow = Val(InputBox("请输入标题的行数，默认标题行数为1", "提醒", 1))
If nTitleRow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
Set shtActive = ActiveSheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
End With
ReDim aResult(1 To 80000, 1 To 1) '声明结果数组
Cells.ClearContents '清空当前表格数据
Cells.NumberFormat = "@" '设置单元格为文本格式
strFileName = Dir(strPath & "*.xls*") '使用Dir函数遍历excel文件
Do While strFileName <> ""
If strFileName <> ThisWorkbook.Name Then '避免同名文件重复打开出错
With GetObject(strPath & strFileName)
'以只读'形式读取文件时，使用getobject会比workbooks.open稍快
For Each shtData In .Worksheets '遍历表
If InStr(1, shtData.Name, strKey, vbTextCompare) Then
'如果表中包含关键字则进行汇总(不区分关键词字母大小写）
Set rng = shtData.UsedRange
If rng.Count > 1 Then '判断工作表是否存在数据……
nShtCount = nShtCount + 1 '汇总工作表的数量
nStartRow = IIf(nShtCount = 1, 1, nTitleRow + 1) '判断遍历数据源是否应该扣掉标题行
aData = rng.Value '数据区域读入数组arr
If UBound(aData, 2) + 2 > UBound(aResult, 2) Then '动态调整结果数组brr的最大列数
ReDim Preserve aResult(1 To UBound(aResult), 1 To UBound(aData, 2) + 2)
End If
For i = nStartRow To UBound(aData) '遍历行
k = k + 1
aResult(k, 1) = strFileName '数组第一列放工作簿名称
aResult(k, 2) = shtData.Name '数组第二列放工作表名称
For j = 1 To UBound(aData, 2) '遍历列
aResult(k, j + 2) = aData(i, j)
Next
If k > UBound(aResult) - 1 Then
'如果数据行数到达结果数组的上限，则将数据导入汇总表，并清空结果数组
With shtActive
nLastRow = .Cells(Rows.Count, 1).End(xlUp).Row '获取放置来源数据的位置
If nLastRow = 1 Then '判断是否扣除标题行
nStarRng = IIf(nTitleRow = 0, 1, 0)
.Range("a1").Offset(nStarRng).Resize(k, UBound(aResult, 2)) = aResult
.Range("a1:b1") = Array("来源工作簿名称", "来源工作表名称")
'前两列放来源工作簿和工作表名称
Else
.Range("a1").Offset(nLastRow).Resize(k, UBound(aResult, 2)) = aResult
'放结果数组的数据
End If
End With
k = 0
ReDim aResult(1 To UBound(aResult), 1 To UBound(aResult, 2))
'重新设置结果数组
End If
Next
End If
End If
Next
.Close False '关闭工作簿
End With
End If
strFileName = Dir '下一个excel文件
Loop
If k > 0 Then
shtActive.Select '激活汇总表
nLastRow = Cells(Rows.Count, 1).End(xlUp).Row '放置数据的位置
If nLastRow = 1 Then '如果汇总表数据为空，说明需要汇总的数据没有超过结果数组的上限
nStarRng = IIf(nTitleRow = 0, 1, 0)
Range("a1").Offset(nStarRng).Resize(k, UBound(aResult, 2)) = aResult
Range("a1:b1") = Array("来源工作簿名称", "来源工作表名称")
Else
Range("a1").Offset(nLastRow).Resize(k, UBound(aResult, 2)) = aResult
End If
End If
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
End With
MsgBox "一共汇总完成。" & nShtCount & "个工作表", , "孙兴华"
End Sub