Option Explicit
Option Base 0
Public Sub フォルダー一括作成マクロ()
Const BASEFOLDER = "G:\" '基本のフォルダー
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer, Kp As Integer
Dim varFldN As Variant, varWork As Variant
Dim strFldN() As String
Dim intFldL() As Integer
Dim varTemp As Variant, strTemp As String
'############################
' フォルダー名テーブル (1;→1-1;→1-1-1;→1-1-1-1;
'############################
varFldN = Array("1;関東", "2;関西", "3;北陸", _
"1-1;東京都", "1-2;神奈川県", "1-3;千葉県", _
"1-4;埼玉県", "1-5;茨城県", "1-6;栃木県", _
"1-7;群馬県", _
"2-1;大阪府", "2-2;京都府", "2-3;兵庫県", _
"2-4;滋賀県", "2-5;奈良県", "2-6;和歌山県", _
"3-1;富山県", "3-2;石川県", "3-3;福井県", _
"1-1-1;千代田区", "1-1-2;港区", "1-1-3;港区", _
"1-2-1;横浜市", "1-2-2;横須賀市", _
"2-1-1;大阪市", "2-1-2;堺市", "2-1-3;吹田市", _
"2-2-1;京都市", "2-2-2;宇治市", _
"2-2-3;長岡京市", _
"2-3-1;神戸市", "2-3-2;明石市", _
"3-1-1;富山市", "3-2-1;金沢市", "3-2-2;加賀市", _
"3-3-1;福井市", "3-3-2;坂井市", "3-3-3;勝山市", _
"3-3-4;敦賀市", "3-3-5;越前市", "3-3-6;鯖江市")
'
If MsgBox("フォルダー一括作成しますか？", vbYesNo+vbExclamation) _ = vbNo Then
Exit Sub
End If
'
'*配列再定義
ReDim strFldN(UBound(varFldN, 1), 2), intFldL(UBound(varFldN, 1))
'*番号と名称を分離
For Ip = LBound(varFldN, 1) To UBound(varFldN, 1)
varWork = Split(varFldN(Ip), ";")
varTemp = Split(varWork(0), "-"): strTemp = ""
For Jp = LBound(varTemp, 1) To UBound(varTemp, 1)
strTemp = strTemp & Format(Val(varTemp(Jp)), "000") & "-"
Next Jp
strFldN(Ip, 0) = strTemp: strFldN(Ip, 1) = varWork(1)
Next Ip
'
For Ip = LBound(varFldN, 1) To UBound(varFldN, 1)
intFldL(Ip) = -1
If Len(strFldN(Ip, 0)) > 4 Then
strTemp = Left(strFldN(Ip, 0), Len(strFldN(Ip, 0)) - 4)
For Jp = LBound(varFldN, 1) To UBound(varFldN, 1)
If strFldN(Jp, 0) = strTemp Then
intFldL(Ip) = Jp: Exit For
End If
Next Jp
End If
Next Ip
'*パス名生成
For Ip = LBound(varFldN, 1) To UBound(varFldN, 1)
If intFldL(Ip) = -1 Then
strFldN(Ip, 2) = BASEFOLDER & strFldN(Ip, 1)
Else
strFldN(Ip, 2) = strFldN(intFldL(Ip), 2) & "\" & _
strFldN(Ip, 1)
End If
strFldN(Ip, 2) = Replace(strFldN(Ip, 2), "\\", "\")
Next Ip
'*フォルダー作成
Jp = 0
For Ip = LBound(varFldN, 1) To UBound(varFldN, 1)
If Dir(strFldN(Ip, 2), vbDirectory) = "" Then
MkDir strFldN(Ip, 2): Jp = Jp + 1
End If
Next Ip
Ip = MsgBox(Format(Jp, "###0") & _
"個のフォルダーを作成しました。", vbInformation + vbOKOnly)
End Sub
