ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1705|回复: 10

[求助] 获取当前文件夹内的所有文件名称(包括子文件内)

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-2-1 14:52 | 显示全部楼层 |阅读模式
获取当前文件夹内的所有文件名称(包括子文件内),再网上找了一段程序,可行,可是遇到文件夹名称里面带.的就不能获取了比如      20191.1文件夹  这种名称的文件夹就不能获取其内的文件名称,代码如下:
Sub 遍历文件夹()
'Columns(1).Delete
On Error Resume Next
Dim f As String
Dim file() As String
Dim i, k, x
x = 1
i = 1: k = 1
ReDim file(1 To i)
file(1) = InputBox("请输入要查找的文件夹(输入目标文件夹的地址):") & "\"
Application.ScreenUpdating = False '关闭屏幕刷新

Do Until i > k
    f = Dir(file(i), vbDirectory)
        Do Until f = ""
            If InStr(f, ".d") = 0 Then
                k = k + 1
                ReDim Preserve file(1 To k)
                file(k) = file(i) & f & "\"
            End If
            f = Dir
        Loop
    i = i + 1
Loop
For i = 1 To k
    f = Dir(file(i) & "*.*")
    Do Until f = ""
       'Range("a" & x) = f
       Range("a" & x).Hyperlinks.Add Anchor:=Range("a" & x), Address:= _
        file(i) & f, TextToDisplay:=f
        Range("B" & x) = file(i) & f
        x = x + 1
        f = Dir
    Loop
Next
'ActiveSheet.Columns(2).ClearContents
Application.ScreenUpdating = True '打开屏幕刷新
End Sub
测试文件夹见附录

测试包中 有1和1.1两个文件夹,分别有1.txt和1.1.txt两个文件,用这个程序只能看到1.txt这个文件,如果把1.1.txt放到1这个文件夹里就能被找出来,具体原因请大神分析

测试文件.zip

17.71 KB, 下载次数: 72

TA的精华主题

TA的得分主题

发表于 2019-2-1 15:08 | 显示全部楼层
If InStr(f, ".d") = 0 Then 改成 If f <> "." And f <> ".." Then

TA的精华主题

TA的得分主题

发表于 2019-2-1 21:43 | 显示全部楼层
Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
Dim cntFiles% '文件个数
'引用FileSystemObject对象
'注意:要使用FileSystemObject对象,
'需要首先引用一下,具体方法,VBE--工具--引用--找到miscrosoft scription runtime项目并选中
Sub ListAllFiles()
'Call 通过GUID_自动添加_引用_MicrosoftScriptingRuntime
On Error Resume Next
Dim strPath$ '声明文件路径
Dim j%
Dim arr(1 To 500, 1 To 70)
'Set fso = CreateObject("Scripting.FileSystemObject")
Dim fso As New filesystemobject, fd As Folder '创建一个FileSystemObject对象和一个文件夹对象
strPath = ThisWorkbook.Path & "\" '"设置要遍历的文件夹目录
cntFiles = 0
Set fd = fso.GetFolder(strPath) '设置fd文件夹对象
SearchFiles fd '调用子程序查搜索文件

''    For j = 1 To cntFiles
''        '下面可以装入自己想要对所有提取文件进行操作的代码
''        '================================================
''        If ArrFiles(j) Like "*.xls" Or ArrFiles(j) Like "*.xlsx" And ArrFiles(j) <> strPath & ThisWorkbook.Name Then
''            Set wb = Workbooks.Open(ArrFiles(j))
''                With wb
''
''                    With .Sheets(1)
''                        arr(j, 1) = .Range("D1")
''                        arr(j, 2) = .Range("J1")
''                        arr(j, 3) = .Range("O1")
''                        arr(j, 4) = .Range("E7")
''                        arr(j, 5) = .Range("E8")
''                        arr(j, 6) = .Range("E9")
''                        arr(j, 7) = .Range("E10")
''                        arr(j, 8) = .Range("E11")
''                        arr(j, 9) = .Range("E12")
''                        arr(j, 10) = .Range("E13")
''                        arr(j, 11) = .Range("M7")
''                        arr(j, 12) = .Range("M8")
''                        arr(j, 13) = .Range("M9")
''                        arr(j, 14) = .Range("M10")
''                        arr(j, 15) = .Range("M11")
''                        arr(j, 16) = .Range("M12")
''                        arr(j, 17) = .Range("B7")
''                        arr(j, 18) = .Range("B8")
''                        arr(j, 19) = .Range("B9")
''                        arr(j, 20) = .Range("B10")
''                        arr(j, 21) = .Range("B11")
''                        arr(j, 22) = .Range("B12")
''                        arr(j, 23) = .Range("B13")
''                        arr(j, 24) = .Range("J7")
''                        arr(j, 25) = .Range("J8")
''                        arr(j, 26) = .Range("J9")
''                        arr(j, 27) = .Range("J10")
''                        arr(j, 28) = .Range("J11")
''                        arr(j, 29) = .Range("J12")
''                        arr(j, 30) = .Range("J15")
''                        arr(j, 31) = .Range("J16")
''                        arr(j, 32) = .Range("J17")
''                        arr(j, 33) = .Range("J18")
''                        arr(j, 34) = .Range("J19")
''                        arr(j, 35) = .Range("J20")
''                        arr(j, 36) = .Range("J21")
''                        arr(j, 37) = .Range("J22")
''                        arr(j, 38) = .Range("J23")
''                        arr(j, 39) = .Range("J24")
''                        arr(j, 40) = .Range("J25")
''                        arr(j, 41) = .Range("J26")
''                        arr(j, 42) = .Range("J27")
''                        arr(j, 43) = .Range("J28")
''                        arr(j, 44) = .Range("J29")
''                        arr(j, 45) = .Range("J30")
''                        arr(j, 46) = .Range("J31")
''                        arr(j, 47) = .Range("J32")
''                        arr(j, 48) = .Range("J33")
''                        arr(j, 49) = .Range("J34")
''                        arr(j, 50) = .Range("C15")
''                        arr(j, 51) = .Range("C16")
''                        arr(j, 52) = .Range("C17")
''                        arr(j, 53) = .Range("C18")
''                        arr(j, 54) = .Range("C19")
''                        arr(j, 55) = .Range("C20")
''                        arr(j, 56) = .Range("C21")
''                        arr(j, 57) = .Range("C22")
''                        arr(j, 58) = .Range("C23")
''                        arr(j, 59) = .Range("C24")
''                        arr(j, 60) = .Range("C25")
''                        arr(j, 61) = .Range("C26")
''                        arr(j, 62) = .Range("C27")
''                        arr(j, 63) = .Range("C28")
''                        arr(j, 64) = .Range("C29")
''                        arr(j, 65) = .Range("C30")
''                        arr(j, 66) = .Range("C31")
''                        arr(j, 67) = .Range("C32")
''                        arr(j, 68) = .Range("C33")
''                        arr(j, 69) = .Range("C34")
''                    End With
''                    arr(j, 70) = .Name
''                    .Close False
''                End With
''                [a2].Resize(5000, 70).ClearContents
''                [a2].Resize(5000, 70).Borders.LineStyle = xlNone
''                [a2].Resize(j, 70) = arr
''                [a2].Resize(j, 70).Borders.LineStyle = 1
''
''            Set wb = Nothing
''        '================================================
''        End If
''    Next j

Sheets(1).Range("A1").Resize(cntFiles) = Application.Transpose(ArrFiles) '把数组内的路径和文件名放在单元格中

End Sub
Sub SearchFiles(ByVal fd As Folder)
Dim fl As file
Dim sfd As Folder
    For Each fl In fd.Files '通过循环把文件逐个放在数组内
        If fl <> ThisWorkbook.FullName And InStr(fl, "~$") = 0 Then
            cntFiles = cntFiles + 1
'            ArrFiles(cntFiles) = fl.Path
            ArrFiles(cntFiles) = Split(fl.Name, ".t")(0)
        End If
    Next fl
   
    If fd.SubFolders.Count = 0 Then Exit Sub 'SubFolders返回由指定文件夹中所有子文件夹(包括隐藏文件夹和系统文件夹)组成的 Folders 集合
    For Each sfd In fd.SubFolders '在 Folders 集合进行循环查找
        SearchFiles sfd '使用递归方法查找下一个文件夹
    Next
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-12 11:39 | 显示全部楼层
乐乐2006201505 发表于 2019-2-1 21:43
Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
Dim cntFiles% '文件个数
'引用FileSyste ...

谢谢辛苦了

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-12 11:42 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
ione_fox 发表于 2019-2-1 15:08
If InStr(f, ".d") = 0 Then 改成 If f  "." And f  ".." Then

谢谢,能解释下吗?我看不懂 instr函数,度娘了也没看懂

TA的精华主题

TA的得分主题

发表于 2019-2-12 17:46 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-2-13 15:58 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-11 16:35 | 显示全部楼层
Sub 遍历文件夹()
'Columns(1).Delete
On Error Resume Next
Dim f As String
Dim file() As String
Dim i, k, x
x = 1
i = 1: k = 1
ReDim file(1 To i)
file(1) = InputBox("请输入要查找的文件夹(输入目标文件夹的地址):") & "\"
Application.ScreenUpdating = False '关闭屏幕刷新

Do Until i > k
    f = Dir(file(i), vbDirectory)
        Do Until f = ""
            If InStr(f, ".") = 0 Then
                k = k + 1
                ReDim Preserve file(1 To k)
                file(k) = file(i) & f & "\"
            End If
            f = Dir
        Loop
    i = i + 1
Loop
For i = 1 To k
    f = Dir(file(i) & "*.*")
    Do Until f = ""
       'Range("a" & x) = f
       Range("a" & x).Hyperlinks.Add Anchor:=Range("a" & x), Address:= _
        file(i) & f, TextToDisplay:=f
        Range("B" & x) = file(i) & f
        x = x + 1
        f = Dir
    Loop
Next
For i = Range("B" & Cells.Rows.Count).End(xlUp).Row To 1 Step -1
If InStr(1, Range("B" & i), "旧版") > 0 Then
    Rows(i).Delete
  End If
Next
ActiveSheet.Columns(2).ClearContents
Application.ScreenUpdating = True '打开屏幕刷新
End Sub

这个是我再网上找的,还算将就吧

TA的精华主题

TA的得分主题

发表于 2023-8-16 09:18 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
scsaub 发表于 2019-10-11 16:35
Sub 遍历文件夹()
'Columns(1).Delete
On Error Resume Next

TA的精华主题

TA的得分主题

发表于 2023-8-16 10:15 | 显示全部楼层
上次写的一个例子,支持选择路径和筛选文件类型
image.png

列表显示文件夹及其文件下所有文件.zip

29.15 KB, 下载次数: 48

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 07:35 , Processed in 0.052355 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表