批量创建多级文件夹的问题

tianyk

求助:在本论坛搜索了好多类似问题的贴子,始终得不到解决.我想根据"批量生成文件"表的A、B、C三列，批量创建多层子文件夹。请大师帮助。
数据库.rar (148.87 KB, 下载次数: 53)

2018-9-18 09:03 上传

点击文件名下载附件

另外,因外部有新增的报表,可以随时导入到第三层指定的子文件夹(经费,记录)里.

liulang0808

关于创建文件夹及遍历文件的问题
楼主之前已经发过帖子了，建议楼主先查查，看看还有哪些问题待解决吧

tianyk

liulang0808 发表于 2018-9-18 09:05
关于创建文件夹及遍历文件的问题
楼主之前已经发过帖子了，建议楼主先查查，看看还有哪些问题待解决吧

己查看关于此问题的多个贴子,水平有限,特来寻求帮助.谢谢!

liulang0808

1. Sub 按钮2_Click()
   
2.     Set fso = CreateObject("Scripting.FileSystemObject")
   
3.     fth = ThisWorkbook.Path & "\分析表.xlsm"
   
4.     Arr = [a1].CurrentRegion
   
5.     Application.ScreenUpdating = False
   
6.     For j = 2 To UBound(Arr)
   
7.         If Len(Arr(j, 1)) > 0 Then
   
8.             pth = ThisWorkbook.Path & "" & Arr(j, 1)
   
9.             If Not fso.folderexists(pth) Then
   
10.                 MkDir pth
    
11.             End If
    
12.             For i = 2 To UBound(Arr)
    
13.                 If Len(Arr(i, 2)) > 0 Then
    
14.                     pth = ThisWorkbook.Path & "" & Arr(j, 1) & "" & Arr(i, 2)
    
15.                     If Not fso.folderexists(pth) Then
    
16.                         MkDir pth
    
17.                     End If
    
18.                     For l = 2 To UBound(Arr)
    
19.                         If Len(Arr(l, 3)) > 0 Then
    
20.                             pth = ThisWorkbook.Path & "" & Arr(j, 1) & "" & Arr(i, 2) & "" & Arr(l, 3) & ""
    
21.                             If Not fso.folderexists(pth) Then
    
22.                                MkDir pth
    
23.                             End If
    
24.                             fso.CopyFile fth, pth, True
    
25.                         End If
    
26.                     Next l
    
27.                 End If
    
28.             Next i
    
29.         End If
    
30.     Next j
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    

复制代码

liulang0808

附件内容供参考吧，之前发的链接里有相关知识点的，楼主可以再看看的

tianyk

liulang0808 发表于 2018-9-18 09:26
附件内容供参考吧，之前发的链接里有相关知识点的，楼主可以再看看的

谢谢版主.有求有应.感谢朋excelhome论坛.