合并父文件夹下所有子文夹的表格

作用:

1. 合并子文夹下的表格
2. 注明子文夹名

使用场景:

1. 多个浏览器账户下载数据,多个浏览器下载地址设置到子文夹,并备注好名字,比如要在同一网站登录多个账户下载数据并合并
2. 合并数据需要辨认是哪个账户下载的

使用条件:

1. 浏览器设置好下载地址,父文件夹和子文夹关系正确
2. 子文夹下下载只有一个文件(excel表格)
3. 尚不明确

使用方法:

1. 复制代码,粘贴到宏的模块
2. 在空白工作表中,点击运行

成果展示:

复制代码:

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