Excel VBA列出某文件夹下子文件夹及文件名

Question

假设用Str1表示某个本地文件夹，其下有n个子文件夹，每个子文件夹又有若干个文件，怎样用Excel VBA列出文件夹及文件名。假设定义一个数组Str(m,n)，当n=0时，该变量表示文件夹名，当n≠0，表示该文件夹下第n个文件名。

Answer 1

遍历文件夹 并列出文件 & 文件夹 名 代码如下：

在文件夹内 新建 个 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

效果如图：

 

Answer 2

'新建一个模块,复制以下代码进去 '动态创建工具栏控件,运行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

Answer 3

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

验证无误。