選択セル範囲のパスからフォルダを一括作成するマクロ

選択セル範囲にあるフォルダパスからフォルダを一括作成するマクロを紹介します。

日付をTEXTJOIN関数で繋げてフォルダパスを生成するなど、
規則性のあるフォルダを一括生成する際に活用します。

また、以下の記事で紹介している、
「フォルダの構成を新規シートに出力するマクロ」ととても相性が良いです。

↑実行するとこのようなシートが出力されるのですが、
これを置換・挿入・削除などで加工してから本マクロを実行することで、
似た構成のフォルダを微調整して複製することが出来るようになります。

よろしければ一緒にお持ち帰りください。

実行型の便利マクロですので、
Excel起動時に裏で開かれる「個人用マクロブック」などに搭載して使ってください。

クイックアクセスツールバーやショートカットキーへの登録も便利です。

ソースコード

' 選択範囲からフォルダを一括作成
Sub 選択範囲内のフォルダパスからフォルダを一括作成する()
    
    ' 選択範囲を取得（行・列全体選択用にUsedRangeとの交差範囲を取る）
    Dim 選択範囲 As Range
    Set 選択範囲 = Intersect(Selection, ActiveSheet.UsedRange)
    If 選択範囲 Is Nothing Then Exit Sub
    
    ' 選択範囲内のフォルダパスからフォルダを作成
    Dim セル As Range
    For Each セル In 選択範囲.Cells
        
        ' \が2個以上あるセルでフォルダ作成を実行
        If セル.Value Like "*\*\*" Then
            Call フォルダを作成する(セル.Value)
        End If
        
    Next
    
End Sub

' 深い階層のフォルダを一気に作成する汎用関数
Function フォルダを作成する(ByVal 作成フォルダのフルパス As String) As Boolean

    Dim Arr階層ごとのフォルダ名() As String
    Arr階層ごとのフォルダ名 = Split(作成フォルダのフルパス, "\")

    On Error Resume Next
        Dim 作成フォルダパス As String
        作成フォルダパス = Arr階層ごとのフォルダ名(0)
        Dim i As Long
        For i = 1 To UBound(Arr階層ごとのフォルダ名)
            作成フォルダパス = 作成フォルダパス & "\" & Arr階層ごとのフォルダ名(i)
            MkDir 作成フォルダパス
        Next
    On Error GoTo 0
    
    If Dir(作成フォルダのフルパス, vbDirectory) <> "" Then フォルダを作成する = True
End Function

解説

本関数を動かすうえで一番気にしなければいけない仕様が、
MkDir関数の「今あるフォルダのひとつ下のフォルダしか作れない」仕様です。

例えば「"C:\Users\○○\Desktop\商品\くだもの\柑橘\みかん"」
このフォルダを作成する際、もし「商品」フォルダまでしか存在していない場合は、

MkDir "C:\Users\○○\Desktop\商品\くだもの"
MkDir "C:\Users\○○\Desktop\商品\くだもの\柑橘"
MkDir "C:\Users\○○\Desktop\商品\くだもの\柑橘\みかん"

このように上から順番にMkDir関数を実行していく必要があります。

これをいちいち書くのは面倒なので、汎用関数にしてしまいました。

こうすることでメインマクロでは

Call フォルダを作成する(セル.Value)

このコードだけで上記の処理を裏でやってくれるようになります。

こうしてしまえばあとは単純なセルのForEachループを回すだけですね。

本マクロは汎用関数づくりのお手本のようなマクロになりました。

このマクロを持っていくついでに、プロシージャ分割の参考にもしてみて下さい。

中身のコードの詳しい解説はこちらをどうぞ。
www.limecode.jp