1、先在F盘（也可以在其它的非系统盘）——右击——新建——文件夹——然后给文件夹命名为：读取文件夹
2、新建一个空白的EXCEL文档——然后点击文件——保存——保存地址就选择刚刚建立的文件夹那里——然后给文件命名为：读取文件夹名称
3、接着在EXCEL那里同时按alt+F11，打开宏编辑器，点击插入——模块，在模块那里输入如下代码（文件夹的地址可以在电脑地址栏那里复制）：
Sub 提取文件夹名称()
Dim fs As Object
n = 1
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder("F:\读取文件夹")
For Each fd In f.subfolders
Cells(n, 1) = fd.Name
n = n + 1
Next
Set f = Nothing
Set fs = Nothing
End Sub
4、如果想通过VBA代码由自己选择文件夹再执行提取文件夹名称，可以在VBA编辑模块那里输入如下代码：
Sub getFldList1()
Dim Fso, Fld
Dim Arr(1 To 999), k%
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fld = Fso.getfolder(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & "")
For Each fd In Fld.subfolders
k = k + 1
Arr(k) = fd.Name
Next
[A1].Resize(k) = Application.Transpose(Arr)
End Sub
1、案例说明：现在读取文件夹里有三个子文件夹，每个子文件夹都有EXCEL文档，现在要把所有的主文件夹和子文件夹下的EXCEL文件名提取出来。
2、接着点击视图——宏——查看宏（也可以直接按alt+F11)打开宏编辑器——点击插入模块，然后插入如下图的代码：
Sub 遍历文件夹()
'On Error Resume Next
Dim fn(1 To 10000) As String
Dim f, i, k, f2, f3, x
Dim arr1(1 To 100000, 1 To 1) As String, q As Integer
Dim t
t = Timer
fn(1) = ThisWorkbook.Path & "\"
i = 1: k = 1
Do While i < UBound(fn)
If fn(i) = "" Then Exit Do
f = Dir(fn(i), vbDirectory)
Do
If InStr(f, ".") = 0 And f <> "" Then
k = k + 1
fn(k) = fn(i) & f & "\"
End If
f = Dir
Loop Until f = ""
i = i + 1
Loop
'*******接下来是提取各个文件夹的文件***
For x = 1 To UBound(fn)
If fn(x) = "" Then Exit For
f3 = Dir(fn(x) & "*.*")
Do While f3 <> ""
q = q + 1
arr1(q, 1) = fn(x) & f3
f3 = Dir
Loop
Next x
ActiveSheet.UsedRange = ""
Range("a1").Resize(q) = arr1
MsgBox Format(Timer - t, "0.00000")
End Sub
