EXCEL summary file information

'程序：Collect_Workbook
'作者：TED.ZHENG
'功能: 汇总同一目录下EXCEL文件
'效果：将结果输出至同一工作表
'=============================================================
'文件需在同一目录或其下级子目录中
'文件表的格式需安全一致
'生成的文件需被选中
'文件格式为EXCEL
'下限定为10000行，行号过多需手工修改
'==========================================================
Public my_Wb, my_Ws
Public m&, n&
Public a_Out
'汇总同一目录下的工作薄
'工作薄必须为相同格式
Sub Collect_Workbook()
Dim t
Dim s_Path$
t = Time
'活动工作表
my_Ws = ActiveSheet.Name
With Sheets(my_Ws)
    '清除内容
    .UsedRange.ClearContents
    '指定当前工作薄
    Set my_Wb = ThisWorkbook
    '获取所需汇总数据文件夹
    s_Path$ = Select_Folder
    '没有选中，退出程序
    If s_Path = "" Then Exit Sub
    '汇总文件夹中文件
    m = 0
    Collect_Wb (s_Path)
    '输出数据
    .Cells(1, 1).Resize(m, UBound(a_Out, 2)) = a_Out
End With
MsgBox (Time - t)
End Sub

'选中文件夹
Public Function Select_Folder()
Dim myPath$
'运行后出现选择文件夹对话框
With Application.FileDialog(msoFileDialogFolderPicker)
    '如选中则返回-1/取消未选则返回=0
    If .Show Then myPath = .SelectedItems(1) Else Exit Function
End With
'返回选中目标文件夹的绝对路经
'If Right(myPath, 1) <> "" Then Select_Folder = myPath
Select_Folder = myPath
End Function

'递归循环文件夹/子文件夹中文件
Sub Collect_Wb(ByVal Pth$)
Dim k
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(Pth)
    '循环文件夹中文件
    For Each f In ff.Files
        '具体提取哪类文件，还是需要根据文件扩展名进行处理
        If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then
            '不充许是当前文件本身
            If f.Name <> ThisWorkbook.Name Then
                '打开文件
                Set wb = Workbooks.Open(f)
                '循环工作表
                For Each sht In wb.Sheets
                    '记录不为空
                    If WorksheetFunction.CountA(sht.UsedRange) > 1 Then
                        '数据读入内存
                        arr = sht.UsedRange
                        '判定是否为初始记录
                        If m = 0 Then
                            '定义数组范围
                            ReDim a_Out(1 To 10000, 1 To UBound(arr, 2) + 1)
                            k = 1
                        Else
                            k = 2
                        End If
                        '循环数据数组
                        For i = k To UBound(arr)
                            '记录下移
                            m = m + 1
                            '为首行记录
                            If m = 1 Then
                                '记录文件夹地址
                                a_Out(m, 1) = Pth
'                                my_Wb.Sheets(my_Ws).Cells(m, 1) = Pth
                            Else
                                '数据来源
                                a_Out(m, 1) = wb.Name & "\" & sht.Name
'                                my_Wb.Sheets(my_Ws).Cells(m, 1) = wb.Name & "\" & sht.Name
                            End If
                            '循环数组列
                            For j = 1 To UBound(arr, 2)
                                n = j + 1
                                a_Out(m, n) = arr(i, j)
'                                my_Wb.Sheets(my_Ws).Cells(m, n) = arr(i, j)
                            Next j
                        Next i
                    End If
                Next sht
                '关闭文件
                wb.Close False
            End If
        End If
    Next f
    For Each fd In ff.subfolders
        Collect_Wb (fd)
    Next fd
End Sub