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

Posted 2023-03-19

假设用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

效果如图：

 

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

验证无误。

Excel（VBA）列出目录中的所有文件名

Lists all filenames in a directory if you need them for formulae or add into VBA.

Sub ListAllFile() 
 
    Dim objFSO As Object 
    Dim objFolder As Object 
    Dim objFile As Object 
    Dim ws As Worksheet 
 
    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set ws = Worksheets.Add 
 
     'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder("C:") 
    ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & "are:" 
 
     'Loop through the Files collection
    For Each objFile In objFolder.Files 
        ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name 
    Next 
 
     'Clean up!
    Set objFolder = Nothing 
    Set objFile = Nothing 
    Set objFSO = Nothing 
 
End Sub