Excel VBA フォルダ自動作成マクロ(コピペで使える便利機能)

 

日常業務を行うにあたって、複数フォルダを作成することがたまにあるかなと思います。

 

その際にエクセルの表で記載したフォルダ名称で自動作成できたら良いなと考え、フォルダ作成を自動的に行うマクロを作成しましたのでご活用頂けたらと思います。

 

フォルダ自動作成マクロの概要

エクセルに作成したいフォルダ名を記入し、マクロを実行すると、そのExcelファイルが存在しているパスに指定したフォルダが自動作成されます。

 

ExcelにてVBAコードよりマクロを作成し、ボタン(図形にて作成)をクリックすることでマクロを実行させてフォルダ作成処理を実施します。

 

何ができるマクロなのか?

1.フォルダ自動作成マクロのVBAコードを含んだExcelファイル(***.xlsm)を任意のフォルダに保存して、そのExcelファイルを開きます。

 

2.開いたExcelファイルにフォルダ名を記入して、マクロを実行します。

 

3.開いているExcelファイルがあるフォルダに指定したフォルダが作成されます 。

 

4.フォルダの下階層にも指定したフォルダが作成されています。

 

フォルダ自動作成マクロの使用方法

1.Excelを開き、「開発」タブをクリックして、「Visial Basic」をクリックします。

 

2.「Microsoft Excel Object」にて右クリックして「標準モジュール」を挿入します。

 

3.右側の空欄スペースに下記のVBAコードをコピペで入力します。

Option Explicit

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

'===========================================
'最初に行われるフォルダ自動作成のメイン処理
'===========================================
Sub makeFolder_main()

    Call initialize
    Call errCheck
    Call makeFolder

    If LngErrRow(0) <> "" Then
        MsgBox "赤色で表示された箇所はフォルダ作成されていません"
    Else
        MsgBox "フォルダ作成処理が正常に実行されました"
    End If
    
End Sub

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

    Dim iRow As Long
    
    '表の最終行番号を取得する
    iRow = Range("A1").SpecialCells(xlCellTypeLastCell).row

    '表全体の文字色を黒色に変更する
    Range("A2", "E" & CStr(iRow)).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                         'フォルダ名称が記載されている列番号
    
    'フォルダ名称が記載されている行数分だけ繰り返す
    For row = 2 To Range("A1").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
        
            '問題がない最初の行で一番左の列に値が入っていない場合は処理を終了する
            If baseColNum = 0 And Cells(row, 1) = "" Then
                
                MsgBox "最初のフォルダは最上位階層を指定してください。"
                Call errHandling(arrNum, row)
                End
                
            End If
            
            'フォルダ名称が記載されている列数分だけ繰り返す
            For col = 1 To 5

                '対象セルに値が存在した場合
                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()

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

 

4.ファイルを保存する際は「Excelマクロ有効ブック」を選択して、保存します。

 

5.Excelシートに戻り2行目から下に作成したいフォルダ名を記入します。

(1行目はタイトル行として扱っているため、1行目の値は無視されます)

 

6.上部メニューの「挿入」タブ→「図形」→「四角形」を選択して、シート内に図形を作成します。

※図形のデザインはお好みで設定します。

 

7.6で作成した図形にメイン処理「makeFolder_main」のマクロを設定します。

8.7でマクロ登録した図形にカーソルを当てて、指の形になっているのを確認してクリックします。

左のセルに記入されたフォルダ名でフォルダが自動作成されます。

 

このマクロを使う上での注意点

当マクロを使用するにあたって、指定するフォルダ名称の記入位置などのルールがありますので、以下を確認してください。

 

一番最初に指定するフォルダは最上位の階層を指定する

(注意)最初に作成されるフォルダは一番左の列に記入してください。

一つの行に複数のフォルダ名の指定をしない

(注意)1行で記入できるセルは一つだけです。

 

二つ以上飛ばした下位階層に対してフォルダ名を指定しない

(注意)一つフォルダ名を指定したら、その下の行には同じ列か、左の列にのみフォルダ名を記入できます。

 

上記のルールを守っていない行は、フォルダ自動作成の対象から外れます。

 

その場合、誤っている箇所を赤色で表示させ、当該行の処理はスキップされます。

※最初のフォルダが一番左の列を指定していない場合は、エラーメッセージを表示して処理を終了します。

 

また、実行後に指定したフォルダが全て作成されたか、誤ったフォルダ指定をした箇所があるか、どちらかのメッセージが表示されますので確認してください。

 

なお、当マクロの開発環境として、OSは “Windows10” 、Excelのバージョンは “Microsoft Office 365 バージョン2006″ で行っており、当環境では動作確認ができていますが、他のすべての環境で正常に動作するかは確認できていません。

 

正常に動作しない場合は、コメントいただければ幸いです。

 

サンプルのダウンロードはこちら

 フォルダ自動作成マクロのツール本体

 

上記よりダウンロードして、VBAコードを組み込んでマクロを使用してください。
※マクロをインターネットからダウンロードするのはリスクを伴うと思いますので、マクロ入りでなくエクセル形式でアップロードしています。
 

Follow me!

Excel VBA フォルダ自動作成マクロ(コピペで使える便利機能)” に対して3件のコメントがあります。

  1. 村上 より:

    お知恵を拝借させていただきました。ありがとうございました。
    膨大な時間がかかる筈だった業務の、大幅な時間短縮を図ることができました。

    生成したフォルダに、PDFファイルを格納していきたいのですが
    リスト化したものを(このファイル名はこのフォルダに格納する、という情報が記載されているもの)用いて、マクロを組むことはできるのでしょうか。

    当方、自粛期間中にマクロを習得しましたがまだまだ経験不足のため
    お力をお貸しいただけますと幸いです。
    不躾なご依頼誠に恐縮ですが、どうぞご検討のほどよろしくお願いいたします。

    1. RH より:

      管理人のRHです。
      村上様、閲覧頂きまして、ありがとうございます。
      完璧ではないかもしれませんが、実現したい機能のイメージは伝わりました。
      マクロで実現可能だと思いますが、このコメント欄で全て説明するのは、とても大変そうです。
      そのため、遠くない先、次の業務効率化ツールを作成する際は村上様のイメージされている機能を満たしたマクロを作成しようと思います。

  2. 宮坂 より:

    こちらのマクロを使って一括で階層化されたフォルダを作成することができました。
    ありがとうございます!

    一点問題を見つけたので報告させていただきたいと思います。
    ▼環境
    Windows10
    Excel2019

    ▼問題
    6列目以降にフォルダ名を記載して階層を指定していると、6列目以降のフォルダ作成が無視されてしまう。

    例えば以下のように指定すると、Voice、SE、BGMといったフォルダが作成されないようでした。
    ——————————————–
    Content
    Main
    Common
    Texture
    Animation
    Media
    Audio
    Voice
    SE
    BGM
    Video
    ——————————————–

コメントを残す

CAPTCHA