【知らなくても使える】複数のフォルダを階層指定して作成するマクロツール（Excel VBA）

Option Explicit

'-----（設定値）------------------------
Private Const HEAD_ROW = 6                  '１．テーブル見出し行の行番号
Private Const HEAD_COL_NUM = 2              '２．テーブル見出し行の最初の列番号
Private Const HEAD_END_COL_NUM = 6          '３．テーブル見出し行の最終列の列番号
Private Const PATH_DELIMITER = "/"          '４．パスの区切り文字

'-----（メッセージ）-------------------
Private Const Msg1 = "フォルダ作成処理が正常に実行されました"
Private Const Msg2 = "作成したフォルダを保存する先のフォルダを指定して下さい。"
Private Const WMsg1 = "赤色で表示された箇所はフォルダ作成されていません"
Private Const WMsg2 = "最初のフォルダで最上位階層を指定してください。"
Private Const EMsg1 = "予期せぬエラーが発生しました"
'---------------------------------------

Private LngErrRow() As String               'エラーが発生した行数

'===========================================
'フォルダ作成（ツールと同階層）を実行した際の処理
'===========================================
Sub フォルダ作成実行_click()

    On Error GoTo err
    
    ActiveSheet.Shapes(Application.Caller).Visible = False     'ボタンを非表示にして押し込む動作をつける
    Application.ScreenUpdating = True
        
    Call initialize
    Call errCheck
    Call makeFolder(ThisWorkbook.Path)

    If LngErrRow(0) <> "" Then
        MsgBox WMsg1
    Else
        MsgBox Msg1
    End If
    
    ActiveSheet.Shapes(Application.Caller).Visible = True
    
    Exit Sub
err:
    MsgBox EMsg1, vbOKOnly + vbCritical
    
    ActiveSheet.Shapes(Application.Caller).Visible = True
    
End Sub

'===========================================
'フォルダ作成（フォルダ選択ダイアログから選択）を実行した際の処理
'===========================================
Sub 作成先を指定してフォルダ作成実行_click()

    On Error GoTo err
    
    ActiveSheet.Shapes(Application.Caller).Visible = False     'ボタンを非表示にして押し込む動作をつける
    Application.ScreenUpdating = True
    
    Call initialize
    Call errCheck
    
    Dim importDir As String     '指定したフォルダ名
    
    'フォルダ選択ダイアログを表示させる
    With Application.FileDialog(msoFileDialogFolderPicker)
    
        .Title = Msg2
        
        If .Show <> 0 Then
            importDir = .SelectedItems(1)
        Else
            GoTo lastProcess
        End If
    
    End With
    
    Call makeFolder(importDir)

    If LngErrRow(0) <> "" Then
        MsgBox WMsg1
    Else
        MsgBox Msg1
    End If

lastProcess:
    ActiveSheet.Shapes(Application.Caller).Visible = True
    
    Exit Sub
err:
    MsgBox EMsg1, vbOKOnly + vbCritical
    ActiveSheet.Shapes(Application.Caller).Visible = True
    
End Sub

'-------------------------------------
'色の変更、作業行の初期化等を行う
'-------------------------------------
Sub initialize()

    Dim iRow As Long
    
    '表の最終行番号を取得する
    iRow = Cells(HEAD_ROW, HEAD_COL_NUM).SpecialCells(xlCellTypeLastCell).row
    
    '表全体の文字色を黒色に変更する
    Range(Cells(HEAD_ROW + 1, HEAD_COL_NUM), Cells(iRow, HEAD_END_COL_NUM)).Font.ColorIndex = 1
    
    ReDim LngErrRow(0)
    
End Sub

'-----------------------------------------------------------------
'本来のフォルダ構成になっていない行数があった場合エラー処理をする
'-----------------------------------------------------------------
Sub errCheck()
    
    Dim row As Long
    Dim col As Long
    Dim arrNum As Long                          '配列の番号
    
    Dim baseColNum As Long: baseColNum = 0      'フォルダ名称が記載されている比較対象の列番号
    Dim fColNum As Long                         'フォルダ名称が記載されている列番号
    
    '最初の行で一番左の列に値が入っていない場合は処理を終了する
    If Cells(HEAD_ROW + 1, HEAD_COL_NUM) = "" Then
        
        MsgBox WMsg2
        Call errHandling(arrNum, HEAD_ROW + 1)
        
        ActiveSheet.Shapes(Application.Caller).Visible = True
        End
        
    End If
    
    'フォルダ名称が記載されている行数分だけ繰り返す
    For row = HEAD_ROW + 1 To Cells(HEAD_ROW, HEAD_COL_NUM).SpecialCells(xlCellTypeLastCell).row
        
        '同一行数に複数データが存在する場合はエラーとする
        If WorksheetFunction.CountA(Range(row & ":" & row)) > 1 Then
            
            Call errHandling(arrNum, row)
            GoTo continue
            
        '同一行数に値が一つだけある場合は別のエラーチェックをする
        ElseIf WorksheetFunction.CountA(Range(row & ":" & row)) = 1 Then
                    
            'フォルダ名称が記載されている列数分だけ繰り返す
            For col = HEAD_COL_NUM To HEAD_END_COL_NUM

                '対象セルに値が存在した場合
                If Cells(row, col) <> "" Then
                    fColNum = col
                    Exit For
                End If

            Next col

            '想定されていない箇所にフォルダ名称がある場合はエラーとする
            If (baseColNum = 1 And (fColNum = 3 Or fColNum = 4 Or fColNum = 5)) Or _
                (baseColNum = 2 And (fColNum = 4 Or fColNum = 5)) Or _
                (baseColNum = 3 And fColNum = 5) Then

                Call errHandling(arrNum, row)
                GoTo continue
            
            Else
                
                'フォルダ名が記載された位置に問題なければ、比較元の列番号を変更する
                baseColNum = fColNum
                
            End If
        End If
        
continue:
    Next row

End Sub

'---------------------------------------------------
'記載されている通りの構成と名称でフォルダを作成する
'---------------------------------------------------
Sub makeFolder(folderPath As String)

    Dim row As Long
    Dim col As Long
    
    Dim layerNm1 As String
    Dim layerNm2 As String
    Dim layerNm3 As String
    Dim layerNm4 As String
    Dim layerNm5 As String
    
    Dim fPath As String
    Dim fName As String

    'フォルダ名称が記載されている行数分だけ繰り返す
    For row = HEAD_ROW + 1 To Cells(HEAD_ROW, HEAD_COL_NUM).SpecialCells(xlCellTypeLastCell).row
        
        'エラー対象の行はフォルダ作成処理から外す
        If UBound(Filter(LngErrRow, CStr(row))) <> -1 Then
            GoTo continue
        End If
        
        'フォルダ名称が記載されている列数分だけ繰り返す
        For col = HEAD_COL_NUM To HEAD_END_COL_NUM
            
            If Cells(row, col) <> "" Then
            
                Select Case col
                    Case HEAD_COL_NUM
                        layerNm1 = Cells(row, col)
                        fPath = ""
                    Case HEAD_COL_NUM + 1
                        layerNm2 = Cells(row, col)
                        fPath = PATH_DELIMITER & layerNm1
                    Case HEAD_COL_NUM + 2
                        layerNm3 = Cells(row, col)
                        fPath = PATH_DELIMITER & layerNm1 & PATH_DELIMITER & layerNm2
                    Case HEAD_COL_NUM + 3
                        layerNm4 = Cells(row, col)
                        fPath = PATH_DELIMITER & layerNm1 & PATH_DELIMITER & layerNm2 & PATH_DELIMITER & layerNm3
                    Case HEAD_COL_NUM + 4
                        layerNm5 = Cells(row, col)
                        fPath = PATH_DELIMITER & layerNm1 & PATH_DELIMITER & layerNm2 & PATH_DELIMITER & layerNm3 & PATH_DELIMITER & layerNm4
                End Select
                
                fName = Cells(row, col)
                
                Exit For
            End If
        Next col
        
        '指定されたフォルダ構成と名称のフォルダが既に存在していたらフォルダ作成を行わない
        If Dir(folderPath & fPath & PATH_DELIMITER & fName, vbDirectory) = "" Then
            
            'フォルダ作成処理
            MkDir folderPath & fPath & PATH_DELIMITER & fName
            
        End If
continue:
    Next row
    
End Sub

'-----------------------------------------------------------
'エラーがあった行は赤色表示にして、フォルダ作成対象から外す
'-----------------------------------------------------------
Sub errHandling(arrNum As Long, errRow As Long)
    
    ReDim Preserve LngErrRow(arrNum)
    LngErrRow(arrNum) = CStr(errRow)
    
    '文字色を赤色に変更する
    Rows(errRow).Font.ColorIndex = 3

    arrNum = arrNum + 1
    
End Sub

'===========================================
'当ファイルのエクセル内の値を変更した後に実行する処理
'===========================================
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    Dim i, iCol, iRow As Long
    Dim selSRow, selERow As Long
    Dim existFlg As Boolean
    
    selSRow = Range(Selection.Rows(1).Address).row
    selERow = Range(Selection.Rows(Selection.Rows.Count).Address).row
    
    iCol = Target.Column
    iRow = Target.row
    
    If selSRow = selERow Then
        selSRow = iRow
        selERow = iRow
    End If
    
    '選択範囲が表内であれば色を変える処理をする
    If iRow >= HEAD_ROW + 1 And iCol <= HEAD_END_COL_NUM Then
        
        For iRow = selSRow To selERow
            For i = HEAD_COL_NUM To HEAD_END_COL_NUM
                If ActiveSheet.Cells(iRow, i).Value <> "" Then
                    ActiveSheet.Cells(iRow, i).Interior.Color = RGB(255, 255, 255)
                    existFlg = True
                Else
                    ActiveSheet.Cells(iRow, i).Interior.Color = RGB(220, 220, 220)
                End If
            Next
            If existFlg = False Then
                ActiveSheet.Range(Cells(iRow, HEAD_COL_NUM), Cells(iRow, HEAD_END_COL_NUM)).Interior.Color = RGB(255, 255, 255)
            End If
            existFlg = False
        Next
    End If
    
End Sub