假设用Str1表示某个本地文件夹，其下有n个子文件夹，每个子文件夹又有若干个文件，怎样用Excel VBA列出文件夹及文件名。假设定义一个数组Str(m,n)，当n=0时，该变量表示文件夹名，当n≠0，表示该文件夹下第n个文件名。
遍历文件夹 并列出文件 & 文件夹 名 代码如下：
在文件夹内 新建 个 Excel文件
Excel文件内 按 Alt+F11 视图--代码窗口， 把如下代码复制进去， F5运行
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
效果如图：
温馨提示：答案为网友推荐，仅供参考
第1个回答 2013-06-20
'新建一个模块,复制以下代码进去 '动态创建工具栏控件,运行CreateToolBar过程看一下主界面的工具条
Sub CreateToolBar()
With Application.CommandBars.Add(Name:="文件管理", Position:=msoBarTop, temporary:=True)
.Visible = True
With .Controls.Add(Type:=msoControlPopup, temporary:=True)
.Caption = "目录列表 C:\"
.TooltipText = "C:\"
.OnAction = "CreateChildFolder"
End With
With .Controls.Add(Type:=msoControlPopup, temporary:=True)
.Caption = "目录列表 D:\"
.TooltipText = "D:\"
.OnAction = "CreateChildFolder"
End With
With .Controls.Add(Type:=msoControlPopup, temporary:=True)
.Caption = "目录列表 E:\"
.TooltipText = "E:\"
.OnAction = "CreateChildFolder"
End With
With .Controls.Add(Type:=msoControlPopup, temporary:=True)
.Caption = "目录列表 F:\"
.TooltipText = "F:\"
.OnAction = "CreateChildFolder"
End With
End With
End SubPrivate Sub CreateChild(Parent As Office.CommandBarPopup, FolderPath As String)
Dim iFolder As String, iFile As String, Ctl As CommandBarControl
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
For Each Ctl In Parent.Controls
Ctl.Delete
Next
With Parent.Controls
iFolder = Dir(FolderPath, vbDirectory)
Do While iFolder <> ""
If iFolder <> "." And iFolder <> ".." Then
If (GetAttr(FolderPath & iFolder) And vbDirectory) = vbDirectory Then
With .Add(Type:=msoControlPopup, temporary:=True)
.Caption = iFolder
.TooltipText = FolderPath & iFolder
.OnAction = "CreateChildFolder"
End With
End If
End If
iFolder = Dir
Loop
iFile = Dir(FolderPath & "\*.*")
Do While iFile <> ""
With .Add(Type:=msoControlButton, temporary:=True)
.Caption = iFile
.TooltipText = FolderPath & "\" & iFile
.OnAction = "OpenFile"
End With
iFile = Dir
Loop
End With
End SubPrivate Sub CreateChildFolder()
Dim MyPopup As Office.CommandBarPopup
Set MyPopup = Application.CommandBars.ActionControl
Call CreateChild(MyPopup, MyPopup.TooltipText)
End SubPrivate Sub OpenFile()
ActiveWorkbook.FollowHyperlink CommandBars.ActionControl.TooltipText
End Sub
Sub CreateToolBar()
With Application.CommandBars.Add(Name:="文件管理", Position:=msoBarTop, temporary:=True)
.Visible = True
With .Controls.Add(Type:=msoControlPopup, temporary:=True)
.Caption = "目录列表 C:\"
.TooltipText = "C:\"
.OnAction = "CreateChildFolder"
End With
With .Controls.Add(Type:=msoControlPopup, temporary:=True)
.Caption = "目录列表 D:\"
.TooltipText = "D:\"
.OnAction = "CreateChildFolder"
End With
With .Controls.Add(Type:=msoControlPopup, temporary:=True)
.Caption = "目录列表 E:\"
.TooltipText = "E:\"
.OnAction = "CreateChildFolder"
End With
With .Controls.Add(Type:=msoControlPopup, temporary:=True)
.Caption = "目录列表 F:\"
.TooltipText = "F:\"
.OnAction = "CreateChildFolder"
End With
End With
End SubPrivate Sub CreateChild(Parent As Office.CommandBarPopup, FolderPath As String)
Dim iFolder As String, iFile As String, Ctl As CommandBarControl
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
For Each Ctl In Parent.Controls
Ctl.Delete
Next
With Parent.Controls
iFolder = Dir(FolderPath, vbDirectory)
Do While iFolder <> ""
If iFolder <> "." And iFolder <> ".." Then
If (GetAttr(FolderPath & iFolder) And vbDirectory) = vbDirectory Then
With .Add(Type:=msoControlPopup, temporary:=True)
.Caption = iFolder
.TooltipText = FolderPath & iFolder
.OnAction = "CreateChildFolder"
End With
End If
End If
iFolder = Dir
Loop
iFile = Dir(FolderPath & "\*.*")
Do While iFile <> ""
With .Add(Type:=msoControlButton, temporary:=True)
.Caption = iFile
.TooltipText = FolderPath & "\" & iFile
.OnAction = "OpenFile"
End With
iFile = Dir
Loop
End With
End SubPrivate Sub CreateChildFolder()
Dim MyPopup As Office.CommandBarPopup
Set MyPopup = Application.CommandBars.ActionControl
Call CreateChild(MyPopup, MyPopup.TooltipText)
End SubPrivate Sub OpenFile()
ActiveWorkbook.FollowHyperlink CommandBars.ActionControl.TooltipText
End Sub
第2个回答 2013-06-20
Sub xxx()
Dim Str1 As String, tMp As String
Dim xStr(0 To 99, 0 To 99) As String
Dim i, j, k As Integer
Str1 = "D:\Test"
ChDrive Left(Str1, 1)
ChDir Str1
tMp = Dir$("", 16)
i = 0
Do Until Len(tMp) = 0
If InStr(tMp, ".") = 0 Then
xStr(i, 0) = tMp
i = i + 1
End If
tMp = Dir$
Loop
For k = 0 To i - 1
ChDir Str1 & "\" & xStr(k, 0)
j = 1
tMp = Dir$("")
Do Until Len(tMp) = 0
xStr(k, j) = tMp
j = j + 1
tMp = Dir$
Loop
Next k
End Sub
验证无误。本回答被网友采纳
Dim Str1 As String, tMp As String
Dim xStr(0 To 99, 0 To 99) As String
Dim i, j, k As Integer
Str1 = "D:\Test"
ChDrive Left(Str1, 1)
ChDir Str1
tMp = Dir$("", 16)
i = 0
Do Until Len(tMp) = 0
If InStr(tMp, ".") = 0 Then
xStr(i, 0) = tMp
i = i + 1
End If
tMp = Dir$
Loop
For k = 0 To i - 1
ChDir Str1 & "\" & xStr(k, 0)
j = 1
tMp = Dir$("")
Do Until Len(tMp) = 0
xStr(k, j) = tMp
j = j + 1
tMp = Dir$
Loop
Next k
End Sub
验证无误。本回答被网友采纳
