如何自动建立多级文件夹目录？

lgw7758

如何根据表中内容自动建立多级文件夹，非常感谢！



多级目录.zip (8.39 KB, 下载次数: 60)

2020-3-13 09:40 上传

点击文件名下载附件

microyip

没看懂要做什么

lgw7758

microyip 发表于 2020-3-13 09:55
没看懂要做什么

自动建立多级文件夹！

山菊花

供参考。

microyip

1. Private dicDir As Object
   
2. Sub 建立多级文件夹()
   
3.     Dim vData As Variant, nLevel As Long, nRow As Long
   
4.    
   
5.     Set dicDir = CreateObject("Scripting.Dictionary")
   
6.     vData = Sheet1.UsedRange.Value
   
7.     For nLevel = 1 To UBound(vData, 2)
   
8.         If Not dicDir.Exists(nLevel) Then Set dicDir(nLevel) = CreateObject("Scripting.Dictionary")
   
9.         For nRow = 2 To UBound(vData)
   
10.             If vData(nRow, nLevel) <> "" Then dicDir(nLevel)(vData(nRow, nLevel)) = 0
    
11.         Next
    
12.     Next
    
13.     CreateDir 1, UBound(vData, 2), ThisWorkbook.Path
    
14. End Sub
    
15. 
    
16. Function CreateDir(ByVal nLevel As Long, ByVal nMaxLevel As Long, ByVal sPath As String)
    
17.     Dim vName As Variant, sNewPath As String, bNew As Boolean
    
18.     For Each vName In dicDir(nLevel).Keys
    
19.         sNewPath = Dir(sPath & "" & vName, vbDirectory)
    
20.         bNew = sNewPath = ""
    
21.         If Not bNew Then bNew = GetAttr(sPath & "" & vName) And vbDirectory <> vbDirectory
    
22.         If bNew Then MkDir sPath & "" & vName
    
23.         If nLevel < nMaxLevel Then CreateDir nLevel + 1, nMaxLevel, sPath & "" & vName
    
24.     Next
    
25. End Function

复制代码

microyip

附上附件以供参考

lgw7758

山菊花 发表于 2020-3-13 10:16
供参考。

非常感谢，但建立的文件夹好像不全，存在一点点小问题！

lgw7758

microyip 发表于 2020-3-13 10:23
附上附件以供参考

完美运行，厉害厉害！

FOB_FN_L

一个多级目录创建函数，支持很深的目录。
如：MakeDir "c:\abc\1234\aaaa\1111\6666\ggggggggg\dddddddddd\ssssssss\7676\dsdsds"



Public Function MakeDir(Path As String) As Boolean
    On Error Resume Next
    Dim o_strRet As String
    Dim o_intItems As Integer
    Dim o_vntItem As Variant
    Dim o_strItems() As String
    o_strItems() = Split(Path, "\")
    o_intItems = 0

    For Each o_vntItem In o_strItems()
        o_intItems = o_intItems + 1

        If o_intItems = 1 Then
            o_strRet = o_vntItem
        Else
            o_strRet = o_strRet & "\" & o_vntItem
            MkDir o_strRet
        End If
    Next
    MakeDir = (Err.Number = 0)
End Function

baihushan

感谢分享，学习一下