VBA汇总多个Excel文件数据

1、需求：

将某个文件夹下，所有Excel文件及子文件夹下的Excel文件内容，复制到一张汇总表。

2、举例：

假如你在1个大型集团公司人力部门工作，公司每年都要收集下属上百个子公司、及子公司的子公司的人员信息，这个工作落到你手上了。

糟糕的是这么大的公司没有用系统来管理，必须让各个子公司报Excel表格。
还好的是以前干这活的同事已经把表格规范了，每个子公司都会严格按照规范报，子公司也会收集好子公司的表，并且把自己的子公司的表都单独放在1个文件夹。

你看了看以前年度的数据，大概是这个样子：

你估计上千个文件夹，弄个3、4天应该也可以了。

3、代码实现

让我们看看如何用VBA代码1分钟内搞定。

这个需求的核心是如何能够得到所有的Excel文件路径，只要文件格式一致，打开Excel，复制需要的数据是很简单的。

VBA遍历获取所有文件方法：

调用Dir函数
使用FileSystemObject
使用cmd命令

Dir函数个人觉得不好用，用下面的2种方法。

FileSystemObject方法是对象形式的，好理解，只要能理解递归调用子文件夹：

Function GetFilesFSO(path As String, RetFiles() As String, k As Long) As Long
    Dim fso As Object
    Dim file As Object
    Dim folder As Object, subDir As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.Getfolder(path)
    '遍历文件
    For Each file In folder.Files
        ReDim Preserve RetFiles(k) As String
        RetFiles(k) = file.path
        k = k + 1
    Next file
    '遍历子文件夹
    For Each subDir In folder.Subfolders
        GetFilesFSO subDir.path, RetFiles, k
    Next

    Set file = Nothing
    Set folder = Nothing
    Set subDir = Nothing
    Set fso = Nothing
End Function

cmd命令最简单，随便baidu一下dir命令就可以，运行的时候会有个黑窗跳出一下：

Function GetFilesCmd(path As String) As Variant
    Dim ws As Object
    Dim ws_exec As Object
    Dim str As String
    Dim ret As Variant
    
    Set ws = CreateObject("Wscript.Shell")
   
    Set ws_exec = ws.Exec("cmd.exe /c dir """ & path & """ /b /s /a-d")

    str = ws_exec.StdOut.ReadAll
    '这个最后会有个空白的
    ret = Split(str, vbNewLine)
    
    GetFilesCmd = ret
    
    Set ws_exec = Nothing
    Set ws = Nothing
End Function

得到了所有文件，打开Excel，复制数据就容易了：

Function DoCopy(des As Range, srcfile As String)
    Const COLS As Long = 10 '需要复制的数据列数
    
    Dim wk As Workbook
    
    Set wk = Workbooks.Open(srcfile, False)
    Dim i_row As Long

    ActiveSheet.AutoFilterMode = False
    '找到需要复制的单元格范围
    i_row = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    '记录一下文件的名称
    des.Offset(0, COLS).Resize(i_row, 1).Value = srcfile
    '复制
    Range("A1").Resize(i_row, COLS).Copy des
    '复制完一个文件后，目标单元格下移
    Set des = des.Offset(i_row, 0)
    
    wk.Close False
End Function

主程序：

Sub VBAMain()
    Dim path As String
    
    path = GetFolderPath()
    If VBA.Len(path) = 0 Then Exit Sub
    
'    Dim ret As Variant
'    ret = GetFilesCmd(path)
    
    Dim ret() As String
    GetFilesFSO path, ret, 0
    
    '关闭屏幕更新，防止打开文件的时候不断更新屏幕浪费资源
    Application.ScreenUpdating = False
    
    Dim rng As Range
    Set rng = Range("A1")
    
    Cells.Clear
    Dim i As Long
    For i = 0 To UBound(ret) '使用GetFilesCmd的时候，UBound(ret)后面要-1
        DoCopy rng, VBA.CStr(ret(i))
    Next
    
    Application.DisplayAlerts = True
End Sub

Function GetFolderPath() As String
    Dim myFolder As Object
    Set myFolder = CreateObject("Shell.Application").Browseforfolder(0, "选择要处理的文件夹", 0)
    If Not myFolder Is Nothing Then
        GetFolderPath = myFolder.Self.path
        If Right(GetFolderPath, 1) <> "" Then GetFolderPath = GetFolderPath & ""
    Else
        GetFolderPath = ""
    End If
    Set myFolder = Nothing
End Function

注：程序没有考虑文件夹里可能存在其他类型文件的情况，如果要过滤掉那些不是Excel的文件，需要根据文件后缀来处理。