VBA中DIR方法能不能做到和CMD里那样，可以获取所有文件

忧伤的几次方

由于整理文件需要，最近学习了字典方法，可以实现将文件表中的数据按各种筛选
但需要先取得整个盘符下所有文件
一直使用CMD中的DIR 获取所有文件，比如：Dir  H:\  /s /b >D:\1.xls，Dir  H:\  /b >D:\1.xls获取包含文件名、路径、大小、创建时间、文件类型等等，再通过vba来把清单复制、分列、去空格等操作，但是该方法没办法把多个盘符的文件放到不同的sheet中，而且需要创建多个文件，到2013版本的EXCEL打开xls文件就要点个确认，操作起来没那么简便。
这几天在学习DIR方法获取文件名，但查了许多帖子没有发现DIR方法遍历子文件夹下的子文件夹功能。是否DIR不具备此功能？
又看到FSO方法或许可以实现？
求助各位大神，cmd里的dir能否实现文件放到不同sheet？或者用dir方法是否能实现获取所有文件？FSO呢？

naolew

用双字典配合DIR可以实现，且速度很快，网上有高手的现成代码，本人已收藏，经常引用，现搬运如下，请测试：

   

   

1. Sub Test() '使用双字典，旨在提高速度
   
2.     Dim MyName, Dic, Did, I, T, F, TT, MyFileName
   
3.     T = Time
   
4.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
   
5.     Set Did = CreateObject("Scripting.Dictionary")
   
6.     Dic.Add ("D:"), ""
   
7.     I = 0
   
8.     Do While I < Dic.Count
   
9.         Ke = Dic.keys   '开始遍历字典
   
10.         MyName = Dir(Ke(I), vbDirectory)    '查找目录
    
11.         Do While MyName <> ""
    
12.             If MyName <> "." And MyName <> ".." Then
    
13.                 If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
14.                     Dic.Add (Ke(I) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
15.                 End If
    
16.             End If
    
17.             MyName = Dir    '继续遍历寻找
    
18.         Loop
    
19.         I = I + 1
    
20.     Loop
    
21.     Did.Add ("文件清单"), ""    '以查找D盘下所有EXCEL文件为例
    
22.     For Each Ke In Dic.keys
    
23.         MyFileName = Dir(Ke & "*.xls")
    
24.         Do While MyFileName <> ""
    
25.             Did.Add (Ke & MyFileName), ""
    
26.             MyFileName = Dir
    
27.         Loop
    
28.     Next
    
29.     For Each Sh In ThisWorkbook.Worksheets
    
30.         If Sh.Name = "XLS文件清单" Then
    
31.             Sheets("XLS文件清单").Cells.Delete
    
32.             F = True
    
33.             Exit For
    
34.         Else
    
35.             F = False
    
36.         End If
    
37.     Next
    
38.     If Not F Then
    
39.         Sheets.Add.Name = "XLS文件清单"
    
40.     End If
    
41.     Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
    
42.     TT = Time - T
    
43.     MsgBox Minute(TT) & "分" & Second(TT) & "秒"
    
44. End Sub
    

复制代码

忧伤的几次方

naolew 发表于 2018-8-31 11:40
用双字典配合DIR可以实现，且速度很快，网上有高手的现成代码，本人已收藏，经常引用，现搬运如下，请测试 ...

感谢大佬，确实可行
14行代码改成 Dic.Add (ke(I) & MyName & "\"), ""就运行成功了
有了这个后面就能拓展下去了，顺便问下，fso的方法能行吗？

naolew

忧伤的几次方 发表于 2018-8-31 13:53
感谢大佬，确实可行
14行代码改成 Dic.Add (ke(I) & MyName & "\"), ""就运行成功了
有了这个后面就能 ...

可以呀，大神罗刚君有完整的解决方案，其《excel vba 程度开发自学宝典第3版》中有一个遍历子文件夹创建文件目录的例子，搬运过来，以供参考。

1. Dim arr(), i As Long  '声明公共变量
   
2. Sub 创建文件目录()
   
3.   Dim PathSht As String  '声明变量
   
4.   With Application.FileDialog(msoFileDialogFolderPicker)  '弹出一个对话框用于选择文件夹
   
5.     If .Show Then PathSht = .SelectedItems(1) Else Exit Sub  '如果果选择了“取消”键则结束过程
   
6.   End With
   
7.   PathSht = PathSht & IIf(Right(PathSht, 1) = "", "", "")  '如果路径最右边一个字符不是“\”则追加一个“\”
   
8.   i = 0  '将公共变量i初始化为0
   
9.   Call Contents(PathSht)  '调用过程 Contents创建文件目录
   
10.   Range("A1").Resize(i, 1) = WorksheetFunction.Transpose(arr)  '将结果存放在A列中
    
11.   If MsgBox("是否创建链接?", vbYesNo, "链接") = vbYes Then '如果用户选择了“是”
    
12.     Application.ScreenUpdating = False '关闭屏幕更新
    
13.     For i = 1 To i '遍历数组的每个元素
    
14.       '在A列创建带链接的文件目录(单元格中只显示文件名称)
    
15.       ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=arr(i), TextToDisplay:=Dir(arr(i))
    
16.     Next
    
17.     Application.ScreenUpdating = True '恢复屏幕更新
    
18.   End If
    
19. End Sub
    
20. Sub Contents(Folder As String) '创建一个带参数的过程
    
21.   On Error Resume Next  '如果程序出错则继续执行下一句
    
22.   Dim FolderObj ' As Object '声明一个Object型的变量
    
23.   With CreateObject("Scripting.FileSystemObject") '创建并引用FSO对象
    
24.     For Each FolderObj In .GetFolder(Folder).Files '遍历参数Folder代表的文件夹的子文件
    
25.       i = i + 1 '累加计数器
    
26.       ReDim Preserve arr(1 To i) '重置数组的上标
    
27.       arr(i) = FolderObj.Path '将文件的全名完全导入到数组中
    
28.     Next FolderObj
    
29.     For Each FolderObj In .GetFolder(Folder).SubFolders '遍历参数Folder代表的文件夹的子文件夹
    
30.       Call Contents(FolderObj.Path) '调过程Contents自身提取其子文件夹中的所有文件名称
    
31.     Next FolderObj
    
32.   End With
    
33. End Sub
    

复制代码

zopey

Sub ListFilesDos()
    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
    If Not myFolder Is Nothing Then myPath$ = myFolder.Items.Item.Path Else MsgBox "Folder not Selected": Exit Sub
   
    myFile$ = InputBox("Filename", "Find File", ".xl")
    '在这里输入需要指定的关键字，可以是文件名的一部分，或指定文件类型如 ".xl"
    tms = Timer
    With CreateObject("Wscript.Shell") 'VBA调用Dos命令
        ar = Split(.exec("cmd /c dir /a-d /b /s " & Chr(34) & myPath & Chr(34)).StdOut.ReadAll, vbCrLf) '所有文档含子文件夹
        '指定Dos中Dir命令的开关然后提取结果 为指定文件夹以及所含子文件夹内的所有文件的含路径全名。
        s = "from " & UBound(ar) & " Files by Search time: " & Format(Timer - tms, " 0.00s") & " in: " & myPath
        '记录Dos中执行Dir命令的耗时
        tms = Timer: ar = Filter(ar, myFile) '然后开始按指定关键词进行筛选。可筛选文件名或文件类型
        Application.StatusBar = Format(Timer - tms, "0.00s") & " Find " & UBound(ar) + IIf(myFile = "", 0, 1) & " Files " & s
        '在Excel状态栏上显示执行结果以及耗时
    End With
    [a:a] = "": If UBound(ar) > -1 Then [a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
    '清空A列，然后输出结果
End Sub

忧伤的几次方

zopey 发表于 2018-8-31 16:53
Sub ListFilesDos()
    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFold ...

感谢大佬，原来可以直接打开shell，虽然已经通过2楼的办法实现了想要的结果，不过又涨见识了，万分感谢