1、需求：
将某个文件夹下，所有Excel文件及子文件夹下的Excel文件内容，复制到一张汇总表。
2、举例：
假如你在1个大型集团公司人力部门工作，公司每年都要收集下属上百个子公司、及子公司的子公司的人员信息，这个工作落到你手上了。
- 糟糕的是这么大的公司没有用系统来管理，必须让各个子公司报Excel表格。
- 还好的是以前干这活的同事已经把表格规范了，每个子公司都会严格按照规范报，子公司也会收集好子公司的表，并且把自己的子公司的表都单独放在1个文件夹。
你看了看以前年度的数据，大概是这个样子：
你估计上千个文件夹，弄个3、4天应该也可以了。
3、代码实现
让我们看看如何用VBA代码1分钟内搞定。
这个需求的核心是如何能够得到所有的Excel文件路径，只要文件格式一致，打开Excel，复制需要的数据是很简单的。
VBA遍历获取所有文件方法：
- 调用Dir函数
- 使用FileSystemObject
- 使用cmd命令
Dir函数个人觉得不好用，用下面的2种方法。
FileSystemObject方法是对象形式的，好理解，只要能理解递归调用子文件夹：
代码语言：javascript复制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 Functioncmd命令最简单，随便baidu一下dir命令就可以，运行的时候会有个黑窗跳出一下：
代码语言：javascript复制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，复制数据就容易了：
代码语言：javascript复制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主程序：
代码语言：javascript复制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的文件，需要根据文件后缀来处理。
