求赐教：批量建立文件夹中出现编译问题。

weiyingde

想根据相关信息批量建立文件夹。具体情况是：
附件的表格的D1:EA2区域中的信息建立文件夹，效果如附件中的文件夹。
其中第一行为学生的班号：以"D1"81011为例，说一下其包括的信息：
（1）开头两位数81是班级，即“八（一）班”
（2）中间两位数01，是组别，即“一组”。
（3）最后一位数1，是组内编号，1是一组的组长。
那么对应的D2是程寅，即程寅为八（一）班一组，是组长。
于是根据D1：D2的信息建立文件夹：八年级课文词语\81班\1组【组长程寅】
如法炮制，建立81、82 两个班的所有文件夹。
当然我还通过，一个窗体，可以三种选择：
（1）选择81，只建立81班的所文件夹
（2）选择82，只建立82班的所文件夹
（3）点选窗体中的复选框，选择全部，则实现两个班同时制作目录。
问题：出现编译错误，请大侠一看。
代码如下：
Sub 批量建立文件夹()
On Error Resume Next
Dim par As Paragraph, arr(), bln As Boolean, bln1 As Boolean, bln2 As Boolean
bln = False: bln1 = False: bln2 = False
Cbotx = UserForm2.ComboBox1.Text
rw = ActiveSheet.Range("C65536").End(3).Row
ph = ThisWorkbook.Path
fnm = ActiveSheet.Name
filpth = ph & "\" & fnm & "\"
MkDir filpth
Set d = CreateObject("scripting.dictionary")
Set D1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")
With ActiveSheet
     For m = 4 To 131
       If Cbotx <> "" Then
          If Left(.Cells(1, m).Text, 2) = Cbotx Then
             If Val(Right(.Cells(1, m).Text, 1)) = 1 Then d(Val(Mid(.Cells(1, m).Text, 3, 2))) = .Cells(2, m).Text
             D1(.Cells(2, m).Text) = Val(Mid(.Cells(1, m).Text, 3, 2))
          End If
       Else
          d2(Left(.Cells(1, m).Text, 2)) = ""
          bln1 = True
       End If
     Next
       If bln1 = False Then
          k = d.keys: T = d.Items: CT = d.Count - 1
          Ke1 = D1.keys: Te1 = D1.Items: Cn1 = D1.Count - 1
             If MsgBox("是否建立小组文件夹,若建立选“是”。", vbYesNo, Space(22) & "温馨提示") = vbYes Then
                For ky = 0 To CT
                    If Dir(filpth & Cbotx & "班\" & k(ky) & "组【组长" & T(ky) & "】\") = "" Then MkDir filpth & Cbotx & "班\" & k(ky) & "组【组长" & T(ky) & "】\"
                Next
                bln = True
             Else
                    If Dir(filpth & Cbotx & "班\") = "" Then MkDir filpth & Cbotx & "班\"
             End If
       Else
          ke2 = d2.keys:  Cn2 = d2.Count - 1
             If MsgBox("是否建立小组文件夹,若建立选“是”。", vbYesNo, Space(22) & "温馨提示") = vbYes Then bln2 = True
             For ky1 = 0 To Cn2
                For jj = 4 To 67
                   If Left(.Cells(1, jj).Text, 2) = ke2(ky1) Then
                      If Val(Right(.Cells(1, jj).Text, 1)) = 1 Then d3(Val(Mid(.Cells(1, jj).Text, 3, 2))) = .Cells(2, jj).Text
                      d4(.Cells(2, jj).Text) = Val(Mid(.Cells(1, jj).Text, 3, 2))
                   End
                Next
                If bln2 = True Then
                   ke3 = d3.keys: Te3 = d3.Items: Cn3 = d3.Count - 1
                   For ky2 = 0 To Cn3
                       If Dir(filpth & Cn2(ky1) & "班\" & ke3(ky2) & "组【组长" & Te3(ky2) & "】\") = "" Then MkDir filpth & Cn2(ky1) & "班\" & ke3(ky2) & "组【组长" & Te3(ky2) & "】\"
                   Next
                   d3.RemoveAll
                Else
                       If Dir(filpth & Cn2(ky1) & "班\") = "" Then MkDir filpth & Cn2(ky1) & "班\"
                End If
             Next
        End If
End With
End Sub

weiyingde

再求大侠一看

weiyingde

不要沉下去，过往大侠请援手一救。

weiyingde

再求大侠救急，在线等，先谢了。

maditate

文件夹命名规则。文件夹名不可以包含如下字符： \   /   '   ‘< > 等。自已手动命名一下包含非法字符文件夹，系统会提示那些不可用的。，

wzsy2_mrf

少写了一个if
             For ky1 = 0 To Cn2
                For jj = 4 To 67
                   If Left(.Cells(1, jj).Text, 2) = ke2(ky1) Then
                      If Val(Right(.Cells(1, jj).Text, 1)) = 1 Then d3(Val(Mid(.Cells(1, jj).Text, 3, 2))) = .Cells(2, jj).Text
                      d4(.Cells(2, jj).Text) = Val(Mid(.Cells(1, jj).Text, 3, 2))
                   End  if '这里少了

weiyingde

maditate 发表于 2019-3-12 20:24
文件夹命名规则。文件夹名不可以包含如下字符： \   /   '   ‘< > 等。自已手动命名一下包含非法字符文件 ...

谢谢你，不过不是这个问题。而是用Mkdir创建文件夹，不能一步到位到位，而是要一步一步的创建。

weiyingde

wzsy2_mrf 发表于 2019-3-12 20:28
少写了一个if
             For ky1 = 0 To Cn2
                For jj = 4 To 67

谢谢你，人老眼花，没检查出来。

joforn

送你一个简单的创建目录的函数：

1. 
   
2. #If VBA7 Then
   
3.   Private Declare PtrSafe Function MakeDir Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal DirPath As String) As Long
   
4. #Else
   
5.   Private Declare Function MakeDir Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal DirPath As String) As Long
   
6. #End If
   
7. 
   
8. Sub Test()
   
9.   Debug.Print MakeDir("C:\Test01\Test02\Test03\")
   
10. End Sub
    

复制代码

weiyingde

joforn 发表于 2019-3-13 09:39
送你一个简单的创建目录的函数：

谢谢你。谢谢你的热心，敬佩你技术的精湛！