各位大佬好，我在網上搜了一段代碼，作用是：將多個EXCEL作業簿合并為同一個作業簿的多個不用作業表。第一批表格輸入代碼時完全正常，達到了效果，但在第二批表輸入代碼時顯示下標越界，我對這方面完全小白，代碼也是網上搜的，因為表格量非常大，所以我無從下手，望各位大佬幫我解決一下，這是部分表格以及代碼的百度網盤鏈接，鏈接: https://pan.baidu.com/s/19fmnTObzB6XoAcEhjV042w 提取碼: iu4c
如果大佬不想上鏈接，這是代碼截圖
這是表格截圖，共有62個這樣的表格
uj5u.com熱心網友回復：
看了一下，因為你要復制的那些檔案中中宏代碼，而且是一打開就運行，下標越界不是當前代碼下標越界，而是那些檔案中有下標越界的地方uj5u.com熱心網友回復：
看，這是你52-2.xls中的代碼，
uj5u.com熱心網友回復：
我很好奇你是如何兩次都把不同打錯成不用的。uj5u.com熱心網友回復：
最后解決完了？uj5u.com熱心網友回復：
孫老師代碼 試試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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/246293.html