【Excel VBA】フォルダ自動作成ツール(コピペですぐ使える)

 

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

 

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

 

<更新履歴>

(2022年5月8日:更新) ツールの説明文を1行目に追加、ツールの全体構成の変更、フォルダ名称入力時に同一行をグレーアウトする仕様に変更しました。

 

『フォルダ自動作成ツール』の概要

当ツールであるExcelファイルの表内に作成したいフォルダ名を記入し、マクロを実行すると、当該Excelファイルが存在している階層とそれ以下の階層にそれぞれ指定したフォルダが自動作成されます

 

下に説明動画を載せますので、ご確認ください。

 

説明動画

現在準備中・・・

 

当ツールの使用方法

基本的な機能、操作方法の説明

1.フォルダ自動作成ツールのマクロが入ったExcelファイル(***.xlsm)を開きます。

 

2.表内に作成したいフォルダ名を入力した状態にして、「フォルダ自動作成実行」ボタンをクリックします。

 

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

 

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

 

留意事項

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

 

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

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

 

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

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

 

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

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

 

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

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

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

 

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

 

使用する際の事前準備

このページの下部にある「Excelファイルのサンプル」からExcelファイルを取得し、「準備の手順」内にあるVBAコードを取得したExcelファイルに記載して保存すれば、すぐに当ツールを使用できます。

 

以下にその手順を説明していきます。

 

準備の手順

1.サンプルのダウンロードはこちら」からサンプル(Excelファイル)をダウンロードします。

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、クロ無しExcelファイルを公開しています

 

2.ダウンロードしたExcelファイルの上部にあるリボンの「開発」タブから「visual basic」を選択して、VBE(Visual Basic Editor)を起動させます。

 

3.「ThisWorkbook」をダブルクリックします。

 

4.表示されている右側の欄(エディター)にVBAコードを記載します。

 

以下のVBAコードを「ThisWorkbook」内のエディターにコピーして貼り付けます。

※VBAコードの右上のアイコンをクリックするとソースコードをコピーできます

Option Explicit

'-----(設定値)------------------------
Private Const HEAD_ROW = 4                  '1.テーブル見出し行の行番号
Private Const HEAD_COL_NUM = 1              '2.テーブル見出し行の最初の列番号
Private Const HEAD_END_COL_NUM = 5          '3.テーブル見出し行の最終列の列番号

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

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

'===========================================
'フォルダ自動作成を実行した際の処理
'===========================================
Sub makeFolder_main()

    On Error GoTo err
    
    Dim osVer As String
    osVer = Application.OperatingSystem
    
    Call initialize
    Call errCheck
    Call makeFolder

    If LngErrRow(0) <> "" Then
        MsgBox WMsg1
    Else
        MsgBox Msg1
    End If
    
    Exit Sub
err:
    MsgBox EMsg1, vbOKOnly + vbCritical
    
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                         'フォルダ名称が記載されている列番号
    
    'フォルダ名称が記載されている行数分だけ繰り返す
    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
        
            '問題がない最初の行で一番左の列に値が入っていない場合は処理を終了する
            If baseColNum = 0 And Cells(row, 1) = "" Then
                
                MsgBox WMsg2
                Call errHandling(arrNum, row)
                End
                
            End If
            
            'フォルダ名称が記載されている列数分だけ繰り返す
            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()

    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 = "/" & layerNm1
                    Case HEAD_COL_NUM + 2
                        layerNm3 = Cells(row, col)
                        fPath = "/" & layerNm1 & "/" & layerNm2
                    Case HEAD_COL_NUM + 3
                        layerNm4 = Cells(row, col)
                        fPath = "/" & layerNm1 & "/" & layerNm2 & "/" & layerNm3
                    Case HEAD_COL_NUM + 4
                        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

'===========================================
'当ファイルのエクセル内の値を変更した後に実行する処理
'===========================================
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

 

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

 

6.「フォルダ自動作成実行」ボタンにメイン処理「makeFolder_main」のマクロを設定します。

 

7.「フォルダ自動作成実行」にカーソルを当てて、指の形になっているのを確認してクリックします。

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

 

これで事前準備は完了です。

あとは「当ツールの使用方法」で記載された方法でツールを実行できます。

 

また、このようなExcelVBAを用いた業務効率化を行うときに、以下の書籍が初心者向けでとても参考になると思いますので、良かったらご参照ください。

 

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

 

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

 

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

 フォルダ自動作成のツール(※マクロ無し)

 

上記よりダウンロードして、記事の途中にありましたVBAコードを組み込んでツールを使用してください。

 

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています

 

他に要望等ありましたら、可能な限り改修等を対応しますのでコメント頂ければと思います

 

【Excel VBA】フォルダ自動作成ツール(コピペですぐ使える)” に対して11件のコメントがあります。

  1. 村上 より:

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

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

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

    1. RH より:

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

  2. 宮坂 より:

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

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

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

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

    1. RH より:

      管理人のRHです。

      当ツールをお使い頂き、また併せて問題をご報告いただき、ありがとうございます。

      ご指摘の件ですが、
      当ツールの設計としては、6列目以降の文字はフォルダ作成の対象外となるような作りになっています。

      開発するにあたり固定された数分(今回は5列分)でしかアルゴリズムが思いつかず、6列以上のフォルダ作成に至りませんでした。(力不足ですみません。)

      使いたい等のご要望がありましたら、頑張って考えますので、改めてお教えください。

  3. IT素人 より:

    テキスト内容をコピーして実行してみたのですが、デバックが発生し実行できませんでした。
    マクロ勉強し始めたばかりですので、解決していただけますでしょうか?
    以下にてデバック発生しました。
    ‘指定されたフォルダ構成と名称のフォルダが既に存在していたらフォルダ作成を行わない
    If Dir(ThisWorkbook.Path & fPath & “\” & fName, vbDirectory) = “” Then
    個人のPCはwindows10
    office2019です。
    宜しく御願いいたします。

    1. RH より:

      管理人のRHです。
      当ツールをお使い頂き、また併せて問題をご報告いただき、ありがとうございます。

      以下のコードでエラーが発生して、マクロが正常に動作しなかったとのことですが、デバッグ時のエラー内容は分かりますでしょうか。可能でしたらエラーコード番号とエラーの内容が分かれば原因究明しやすいかと思います。
      例えば、「エラーコード:76」「エラー内容:パスが見つかりません。」など教えていただければ幸いです。
       >‘指定されたフォルダ構成と名称のフォルダが既に存在していたらフォルダ作成を行わない
       >If Dir(ThisWorkbook.Path & fPath & “\” & fName, vbDirectory) = “” Then

      考えられるエラーの可能性としては、「1.フォルダパスが長すぎる。」「2.フォルダ作成しようとしている場所がネットワークドライブ等で特殊な場所」などかと思います。
      その場合は、試しにデスクトップ(Cドライブ)などに当該VBAファイルを置いて実行してみるとどうなるかご確認いただければと思います。

      1. IT素人 より:

        ご回答ありがとうございます。
        エラー内容について共有します。
        「実行時エラー’52’ファイル名または番号が不正です。」とエラー表示されています。

        デスクトップ直下で試してみたのですが同じ結果でした。
        たびたび、申し訳ないのですが問題を判断できる場合ご教示いただけますと幸いです。
        私も勉強としていろいろ試行錯誤してみようと思います…

      2. IT素人 より:

        一度返信してしまったのですが、解決できました。
        解決した内容ですが、ThisWorkbook.Pathがone dirveの影響でエラー吐き出したようです。
        one driveの同期を解除した際に、マクロが正常に動きフォルダ作成致しました!
        ありがとうございました!

        1. RH より:

          管理人のRHです。
          ご連絡いただき、ありがとうございます。

          なるほどですね、one driveと同期していることで当該マクロのパスがone drive先を見にいっていた等で悪影響を及ぼしていたのですね。
          そのような挙動になることは知りませんでした。
           >ThisWorkbook.Pathがone dirveの影響でエラー吐き出したようです。

          IT素人様の環境で動作したということで、良かったです。

  4. Emi より:

    お世話になります。MAC上でこのプログラム使わせていただきました。
    一つ注意点がありましたので、お知らせします。
    MACの場合は、このままコピペすると「実行時エラー ’76’ パスが見つかりません」で実行できません。
    \ となってるところを / に変更したら正常に実行できました。
    MACでも活用させていただきます。ありがとうございました!

    1. RH より:

      管理人のRHです。
      Emiさん、ツールをお使いいただき、ありがとうございます。

      そうなのですね、失礼しました。
      MACでの動作は確認しておりませんでした。

      貴重なご意見ありがとうございます。今後の改修等に役立たせていただきます。
      他のツールもありますので、是非ご活用ください。

コメントを残す

CAPTCHA