读出 路径下 所有的文件夹 及 文件名

丢丢表格

  昨日有同事让我给他写一个宏，要求读出所有文件名。不知是否合要求，所以呈来讨论。     它同于 早些年前的 DIR
（读出 路径下 所有的文件夹 及 文件名，路径一定要完整。可以 从 地址栏用复制的方法 把路径粘帖过来。）

1. 
   

复制代码

Sub test()
    Dim t As Byte
    Dim x As String
    Dim d As String
    x = InputBox("请录入完整的路径")
    Range("a:g").ClearContents
    mypath = x & "\"
    d = Dir(mypath, vbDirectory)
    t = 1
    While d <> ""
        d = Dir
        Cells(t + 3, 3) = d
        t = t + 1
    Wend
       Cells(2, 3) = x
End Sub

文刀天可

1. Dim w(1 To 10000)
   
2. Dim s As Long
   
3. Sub 导入文件()
   
4.     Application.ScreenUpdating = False
   
5.     s = 0
   
6.     Erase w
   
7.     'On Error Resume Next
   
8. 
   
9.     '** 使用FileDialog对象来选择文件夹
   
10.     Dim fd As FileDialog
    
11.     Dim strPath As String
    
12.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)   ' 显示选择文件夹对话框
    
13.     fd.InitialFileName = ThisWorkbook.Path & ""       '设置默认路径
    
14.     If fd.Show = -1 Then        '** 用户选择了文件夹
    
15.         strPath = fd.SelectedItems(1)
    
16.     Else
    
17.         strPath = "": Exit Sub
    
18.     End If
    
19.     Set fd = Nothing
    
20.     '************
    
21.    
    
22.     zdir strPath         '递归所选文件夹内所有子文件夹内文件名，放入数组w
    
23.     Range("b2").Resize(10000) = Application.Transpose(w)
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    
26. 
    
27. 
    
28. Sub zdir(p)       '递归获得本文件夹及所有子文件夹内文件名
    
29.   Set fs = CreateObject("scripting.filesystemobject")
    
30.   For Each f In fs.GetFolder(p).Files
    
31.     If f <> ThisWorkbook.FullName Then s = s + 1: w(s) = f
    
32.   Next
    
33.   For Each m In fs.GetFolder(p).SubFolders
    
34.       zdir m
    
35.   Next
    
36. End Sub
    
37. 
    
38. 
    
39. '使用filesystemobject获得所有文件夹和子文件夹的名称
    
40. Sub zdir1(strpath)
    
41. Set fso = CreateObject("scripting.filesystemobject")
    
42. For Each f In fso.getfolder(strpath).subfolders
    
43. '    If f <> ThisWorkbook.Path Then
    
44.        w(s) = f: s = s + 1
    
45.        zdir1 f
    
46. '    End If
    
47. Next
    
48. 'For Each m In fso.getfolder(strpath).subfolders
    
49. '   zdir m
    
50. 'Next
    
51. End Sub

复制代码

丢丢表格

文刀天可 发表于 2018-3-1 11:50

不是要选定目录，而是通过 文本对话 录入路径，只读目录下级的 文件名。
如 录入 C：    就是读出 C：\  下的所有目录 ，不需读出 C:\*\ 以下的目录。
  谢谢你的回答，

  我写的 句子已经 符合要求，只是语句上是否合理的问题。

文刀天可

丢丢表格 发表于 2018-3-1 12:47
不是要选定目录，而是通过 文本对话 录入路径，只读目录下级的 文件名。
如 录入 C：    就是读出 C：\ ...

可以的，没有什么问题的

丢丢表格

文刀天可 发表于 2018-3-1 12:58
可以的，没有什么问题的

请看 3 楼的示图
每一天做完业务后，需要对文件及 文件夹 有一个记录 。（每天都有增删内容）
  因为过去 都是靠截屏得到的 图片 ，图片多后 数据量庞大，所以写个宏来用数据储存，便于查阅 和 减少存储空间。

6688

Sub lqt()

Dim ay(1 To 10000)
'x = "C:\"
x = ThisWorkbook.Path & "\"
f = Dir(x & "*.???")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        m = m + 1
        ay(m) = f
    End If
    f = Dir
Loop
Range("a65535").End(xlUp).Offset(1).Resize(m) = Application.Transpose(ay)
End Sub

王子熙

原来帮别人写的  为了批量改一个文件夹下 所有文件的名字（包括多级文件夹）       这个主要是得到路径似的 目录   方便以路径找文件改名   不喜勿喷

丢丢表格

6688 发表于 2018-3-1 16:18
Sub lqt()

Dim ay(1 To 10000)

谢谢你的回答，  
你这个是 只读出文件名，没能读出文件夹的，（我要的是也能读出文件夹名的）

丢丢表格

王子熙 发表于 2018-3-1 16:49
原来帮别人写的  为了批量改一个文件夹下 所有文件的名字（包括多级文件夹）       这个主要是得到路径似的 ...

你编写    '获取文件夹下所有文件和文件夹名称
这个可以取用 。
    学习了