提取文件名带路径

陆离Lowry

1. Sub ListFilesTest()
   
2.     With Application.FileDialog(msoFileDialogFolderPicker)
   
3.         If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
   
4.     End With
   
5.     If Right(myPath, 1) <> "" Then myPath = myPath & ""
   
6.    
   
7.     [a:a] = ""
   
8.     Call ListAllFso(myPath)
   
9. End Sub
   
10. 
    
11. Function ListAllFso(myPath$)
    
12.     Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    
13.     For Each f In fld.Files
    
14.         [a65536].End(3).Offset(1) = myPath & f.Name
    
15.     Next
    
16.     For Each fd In fld.SubFolders
    
17.         Call ListAllFso(fd.Path)
    
18.     Next
    
19. End Function
    

复制代码

存的代码改下，输出的位置可以自己稍微改一改，用数组输出，我懒得改了

liulang0808

hhxq001 发表于 2023-1-12 11:06
会把汇总表本身也提取进来呢

增加一个if判断语句吧

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=73cffde5
这个链接资料可以参考的

ivccav

又是等靠要的人。本论坛关于文件操作的帖子，没有1000，也有900，闭着眼睛都搜索到。

smsn

1. Dim Result
   
2. Sub extract()
   
3.     Dim p$, f$, k&, r
   
4.     With Application.FileDialog(msoFileDialogFolderPicker) '获取用户选择文件夹的路径
   
5.         .Title = "请选择文件夹"
   
6.         .InitialFileName = ThisWorkbook.Path & ""            '默认打开当前目录"
   
7.         If .Show = 0 Then MsgBox "本次提取已被取消！！": Exit Sub '如果没有选择保存路径，则退出程序
   
8.         p = .SelectedItems(1) '选择的文件路径赋值给变量P
   
9.     End With
   
10.     If Right(p, 1) <> "" Then p = p & "" '判断p的右侧是否有\，有则查找这个文件夹里的文件
    
11.     'f = Dir(p & "*.*")
    
12.     '返回变量P指定路径下带任意扩展名的文件名
    
13.     '如果有超过一个文件存在，将返回第一个找到的文件名
    
14.     '如果一个文件都没有，则返回空
    
15.     [a:b].ClearContents '清空汇总表的A列原有数据
    
16.     [a1] = "序号" '汇总表的a1写入。。。。
    
17.     [b1] = "文件名如下：" '汇总表的b1写入。。。。
    
18.     '调用底下函数，遍历所有文件，含子文件夹
    
19.     Dim FSOLibrary As Object
    
20.     Dim FSOFolder As Object
    
21.     Dim folderName As String
    
22.     folderName = p
    
23.     Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
    
24.     Result = ""
    
25.     LoopAllSubFolders FSOLibrary.GetFolder(folderName)
    
26.     Result = Application.Transpose(Split(Left(Result, Len(Result) - 2), vbCrLf))
    
27.     Application.ScreenUpdating = False
    
28.     [b2].Resize(UBound(Result), 1) = Result
    
29.     [a2].Resize(UBound(Result), 1) = "=row()-1"
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "提取完成"
    
32.     Set FSOLibrary = Nothing
    
33. End Sub
    
34. 
    
35. Sub LoopAllSubFolders(FSOFolder As Object)
    
36.     Dim FSOSubFolder As Object
    
37.     Dim FSOFile As Object
    
38.     Dim BKFullName As String
    
39.     Dim BKFullName2 As String
    
40.     For Each FSOSubFolder In FSOFolder.subfolders
    
41.         LoopAllSubFolders FSOSubFolder
    
42.     Next
    
43.     BKFullName = ThisWorkbook.FullName:    BKFullName2 = ThisWorkbook.Path & "\~$" & ThisWorkbook.Name
    
44.     For Each FSOFile In FSOFolder.Files
    
45.         If FSOFile.Path <> BKFullName And FSOFile.Path <> BKFullName2 Then
    
46.             Result = Result & FSOFile.Path & vbCrLf
    
47.         End If
    
48.     Next
    
49. End Sub

复制代码

百度拼了个给你。

hhxq001

smsn 发表于 2023-1-12 17:02
百度拼了个给你。

感谢帮助。。。。

hhxq001

坛友们给修改后的：


Sub 提取包含子文件夹()
    With Application.FileDialog(msoFileDialogFolderPicker)     '获取用户选择文件夹的路径
        .Title = "请选择文件夹"
        .InitialFileName = ThisWorkbook.Path & "\"               '默认打开当前目录"
        If .Show = 0 Then MsgBox "本次提取被取消！！": Exit Sub    '如果没有选择保存路径，则退出程序
        myPath$ = .SelectedItems(1)    '选择的文件路径赋值给变量 myPath$
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    [a:b].ClearContents    '清空汇总表的A-B列原有数据
    [a1] = "序号"                   '汇总表的a1写入。。。。
    [b1] = "   文件名如下："    '汇总表的b1写入。。。。
    Call ListAllFso(myPath)       '调用FSO遍历子文件夹的递归过程
End Sub

Function ListAllFso(myPath$)    '用FSO方法遍历并列出所有文件和文件夹名的【递归过程】
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)    '这里的【当前路径myPath是个递归变量】
    For Each f In fld.Files    '遍历当前文件夹内所有【文件.Files】
        If InStr(f.Name, ThisWorkbook.Name) Then GoTo 10    '要提取的文件名不能是本文件
        [B65536].End(3).Offset(1) = fld & "\" & f.Name            '在b列逐个列出文件名
        [B65536].End(3).Offset(, -1) = [A65536].End(3).Row    '在a列填写序号
10  Next
    For Each fd In fld.SubFolders    '遍历当前文件夹内所有【子文件夹.SubFolders】
        Call ListAllFso(fd.Path)    '注意此时的路径变量已经改变为【子文件夹的路径fd.Path】
        '注意重点在这里： 继续向下调用递归过程【遍历子文件夹内所有文件文件夹对象】
    Next
ActiveSheet.Range("a1:a1000").HorizontalAlignment = xlCenter 'a列数据=水平居中
End Function