|
想根据相关信息批量建立文件夹。具体情况是:
附件的表格的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
|
|