Sub 合并父文件下表格()
Dim parentFolderObject As Object
Dim parentFolderPath As String
Dim subFolder As Object
Dim subFolderPaths() As String
Dim subFolderName() As String
Dim fso As Object
Dim i, j, k, Z, L, M, n, p As Long
Dim shtActive, shtActive As Worksheet, rng As Range
Dim aData, aResult, nStarRng, nShtCount As Long
Dim strFileName() As Variant
'取得用户选择的父文件夹路径
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then parentFolderPath = .SelectedItems(1) Else Exit Sub
End With
' 创建文件系统对象
Set fso = CreateObject("Scripting.FileSystemObject")
' 获取父文件夹对象
Set parentFolderObject = fso.GetFolder(parentFolderPath)
'子文件夹路径个数
j = parentFolderObject.Subfolders.Count
' 初始化子文件夹路径数组
ReDim subFolderPaths(1 To j)
ReDim subFolderName(1 To j)
ReDim strFileName(1 To j)
' 遍历子文件夹并存储它们的路径和名字
i = 1
For Each subFolder In parentFolderObject.Subfolders
subFolderPaths(i) = subFolder.Path
subFolderName(i) = subFolder.Name
If Dir(subFolderPaths(i) & "\" & "*.xls*") <> "" Then
strFileName(i) = Dir(subFolderPaths(i) & "\" & "*.xls*") '使用Dir函数遍历excel文件
End If
i = i + 1
Next subFolder
' 释放对象
Set fso = Nothing
Set parentFolderObject = Nothing
'让用户输入标题行数,并在用户提供不合法的输入(负数)时发出警告并取消操作。
' nTitleRow = Val(InputBox("请输入标题的行数,默认标题行数为1", "提醒", 1))
' If nTitleRow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
Set shtActive = ActiveSheet
With Application
.ScreenUpdating = False '将 Excel 的屏幕更新功能关闭
.DisplayAlerts = False '将 Excel 的警告对话框关闭
.AskToUpdateLinks = False '如果工作簿中包含外部链接(例如,链接到其他工作簿的公式),关闭此选项可以避免出现更新链接的提示
End With
ReDim aResult(1 To 80000, 1 To 10) '声明结果数组
Cells.ClearContents '清空当前表格数据
Cells.NumberFormat = "@" '设置单元格为文本格式
n = 0
nStartRow = 1
For Z = 1 To j
If strFileName(Z) <> ThisWorkbook.Name Then '避免同名文件重复打开出错 44{
If Right(subFolderPaths(Z), 1) <> "\" Then subFolderPaths(Z) = subFolderPaths(Z) & "\"
If Dir(subFolderPaths(Z) & "\" & "*.xls*") <> "" Then
With GetObject(subFolderPaths(Z) & Dir(subFolderPaths(Z) & "\" & "*.xls*")) '55{
'以只读'形式读取文件时,使用getobject会比workbooks.open稍快
Set shtData = .Worksheets(1)
Set rng = shtData.UsedRange
If rng.Count > 1 Then '判断工作表是否存在数据…… 66{
nShtCount = nShtCount + 1 '汇总工作表的数量
aData = rng.Value '数据区域读入数组aData
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 L = nStartRow To UBound(aData) '遍历行 77{
n = n + 1
aResult(n, 1) = subFolderName(Z) '数组第一列放子文夹名称
'aResult(n, 2) = shtData.Name '数组第二列放工作表名称
For M = 1 To UBound(aData, 2) '遍历列
p = p + 1
aResult(n, p + 1) = aData(L, M)
Next
p = 0
M = 0
Next '77}
nStartRow = 2
End If '66}
.Close False '关闭工作簿
End With '55}
End If
End If '44}
Next Z
If n > 0 Then
shtActive.Select '激活汇总表
nStarRng = 0
Range("a1").Offset(nStarRng).Resize(n, UBound(aResult, 2)) = aResult
Range("a1") = Array("文件夹名称")
End If
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
End With
End Sub