求列出指定文件夹下所有子文件夹的完整路径填入表中并截取文件夹名称【请看附件】

weist123

求列出指定文件夹下所有子文件夹的完整路径填入表中并截取文件夹名称【请看附件】



希望：
1、点击按钮1，出现一个选择文件夹的窗口，选择好文件夹后，遍历指定文件夹下所有子文件夹，
并把各个子文件夹的完整路径（只填子文件夹路径，不要其中的文件路径）填入A列，从A2单元格开始填充，一行一个；

2、从A列中各个子文件夹路径中截取子文件夹的名称，填充入B列的对应行中；

3、如果指定的文件夹的子文件夹中，还有下一级子文件夹，那么都要列出，但B列的对应位置只能截取最下一层文件夹名称；


谢谢了！

遍历指定文件夹.rar (8.64 KB, 下载次数: 6)

2024-7-20 20:02 上传

点击文件名下载附件

文件夹示例，请解压缩到某路径下：
360极速浏览器下载.rar (771 Bytes, 下载次数: 6)

2024-7-20 21:02 上传

点击文件名下载附件

ykcbf1100

如果指定的文件夹的子文件夹中，还有下一级子文件夹，那是放到C列、D列去？

ykcbf1100

你的附件数据不全，没有子文件夹等结构，不便于调试。

weist123

ykcbf1100 发表于 2024-7-20 20:49
如果指定的文件夹的子文件夹中，还有下一级子文件夹，那是放到C列、D列去？

若还有下一级子文件夹，就截取最下层的文件夹，放B列，上层的不要

weist123

ykcbf1100 发表于 2024-7-20 20:50
你的附件数据不全，没有子文件夹等结构，不便于调试。

文件夹示例已经上传，请老师帮忙调试，谢谢

ykcbf1100

weist123 发表于 2024-7-20 21:02
文件夹示例已经上传，请老师帮忙调试，谢谢

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.7.20
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     On Error Resume Next
   
6.     m = 1
   
7.     For Each fd In fso.GetFolder(p).SubFolders
   
8.         subFolderExists = (fd.SubFolders.Count > 0)
   
9.         If subFolderExists Then
   
10.             For Each fd1 In fd.SubFolders
    
11.                 m = m + 1
    
12.                 Cells(m, 1) = fd1.Path
    
13.                 Cells(m, 2) = fd1.Name
    
14.             Next
    
15.         Else
    
16.             m = m + 1
    
17.             Cells(m, 1) = fd.Path
    
18.             Cells(m, 2) = fd.Name
    
19.         End If
    
20.     Next
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "OK！"
    
23. End Sub
    

复制代码

weist123

ykcbf1100 发表于 2024-7-20 22:05
附件供参考。。。

谢谢老师指导。

但是我希望的是：

点击按钮1，出现一个选择文件夹的窗口，我可以选择任意文件夹，然后会填充表格的，你这个是一点击就ok了。没有选择文件夹。

ykcbf1100

weist123 发表于 2024-7-20 22:26
谢谢老师指导。

但是我希望的是：

改好了，目录自选，默认是当前文件夹

ykcbf1100

目录自选

1. Sub ykcbf()  '//2024.7.21
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .Title = "请选择文件夹"
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         If .Show = -1 Then
   
8.             p = .SelectedItems(1) & ""
   
9.         End If
   
10.     End With
    
11.     On Error Resume Next
    
12.     m = 1
    
13.     For Each fd In fso.GetFolder(p).SubFolders
    
14.         subFolderExists = (fd.SubFolders.Count > 0)
    
15.         If subFolderExists Then
    
16.             For Each fd1 In fd.SubFolders
    
17.                 m = m + 1
    
18.                 Cells(m, 1) = fd1.Path
    
19.                 Cells(m, 2) = fd1.Name
    
20.             Next
    
21.         Else
    
22.             m = m + 1
    
23.             Cells(m, 1) = fd.Path
    
24.             Cells(m, 2) = fd.Name
    
25.         End If
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    

复制代码