セルの値からフォルダを一括で作成する

セルの値を元に、フォルダを一括で作成するコードを紹介します。

例えばこのような処理を行うコードです。

ソースコード

Sub セルの値を元にフォルダを一括作成する()
    
    Dim Path親フォルダ As String
    Path親フォルダ = "C:\Users\○○\Desktop\商品"
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("データ")
    
    Dim 最終行 As Long
    最終行 = ws.UsedRange.Rows.Count + ws.UsedRange.Row - 1
    
    Dim R As Long
    For R = 2 To 最終行
        
        Dim path作成フォルダ As String
        path作成フォルダ = Path親フォルダ & "\" & ws.Cells(R, 1)

        ' フォルダがなければフォルダを作成する
        If Dir(path作成フォルダ, vbDirectory) = "" Then
            MkDir path作成フォルダ
        End If
        
    Next
    
End Sub

解説

コードを読んだ方が早いくらいストレートなFor文ですので、
全体の解説は割愛します。

処理中で注意しなければいけない点ですが、
すでにフォルダがあった場合にMkDirステートメントがエラーになります。

フォルダがないときだけフォルダを作成する必要がありますので、
Dir関数によるフォルダの存在判定を忘れないようにしてください。
（あわせてセル値が空だった時の判定も忘れずに）

逆に言うと、この判定が書かれているため、
セル値側に重複した値が出てくることは問題ありません。

りんご、りんご、りんご、みかん、みかん、といったセル値でも、
しっかりと「りんご」「みかん」の2フォルダだけ作成してくれます。

フォルダの存在判定について、詳しくはこちらをどうぞ。
www.limecode.jp

汎用関数化

この処理をよく書く人は、汎用関数にしておくと便利です。

関数コードと実行コードのサンプルが以下の通りです。

' 汎用関数
Sub フォルダを一括作成する(Rangeフォルダ名リスト As Range, Path親フォルダ As String)
    
    Dim cell As Range
    For Each cell In Rangeフォルダ名リスト.Cells
        If cell.Value <> "" Then
        
            Dim path作成フォルダ As String
            path作成フォルダ = Path親フォルダ & "\" & cell.Value
            
            If Dir(path作成フォルダ, vbDirectory) = "" Then
                MkDir path作成フォルダ
            End If
        
        End If
    Next
End Sub

' 実行例
Sub Thisworkbookと同じフォルダ内にフォルダを一括作成する()
    With Thisworkbook.Worksheets("データ")
    
        Dim 最終行 As Long
        最終行 = .UsedRange.Rows.Count + .UsedRange.Row - 1

        Call フォルダを一括作成する(.Range(.Cells(2, 1), .Cells(最終行, 1)) _
                                           , ThisWorkbook.Path)
        
    End With
End Sub

　
実行例を見ての通り、本体マクロはとても読みやすいコードになりました。

冒頭のコードは「縦1列のデータ」に対して実行したため、
行(R)をつかったForステートメントで書いていましたが、

この汎用関数はどんな形のセル範囲でも実行ができるよう、
Rangeオブジェクトを引数として受け取り、
その中のCellをすべて処理するFor Eachステートメントで書いています。

渡したのがRangeオブジェクトならなんでもフォルダを作ってくれますので、
今回のデータもこんな渡し方で実行することもできます。

Sub Thisworkbookと同じフォルダ内にフォルダを一括作成する2()
    Call フォルダを一括作成する(Worksheets("データ").Range("A1").CurrentRegion.Offset(1), ThisWorkbook.Path)
End Sub

　
Rangeオブジェクトの渡し方も、いろいろと研究してみてください。

汎用マクロ化（リボンやツールバーにセット）

先ほどの汎用関数はどんなRangeオブジェクトでも動かせますので、
Selectionに対してももちろん実行ができます。

そのマクロを用意し、リボンやツールバーにセットしておけば、
選択セルから即席でフォルダを作る便利マクロにできます。

Sub 選択セルからフォルダを一括作成する()
    Dim 親フォルダ As String
    親フォルダ = ThisWorkbook.Path & "\作成フォルダ集_" & Format(Now, "yyyymmddhhmm")
    MkDir 親フォルダ
    Call フォルダを一括作成する(Selection, 親フォルダ)
End Sub

汎用関数があるととても簡単に作れますね。

このマクロを実行すると、「作成フォルダ集_202212202150」といったフォルダがアクティブブックと同フォルダ内に作られ、
その中にすべての選択セルの値からフォルダが作られます。

作業者ごとのフォルダを作ったり、日付ごとのフォルダを作るなど、
フォルダを一括作成する業務が多い方はこのマクロを活用してみてください。

さらにこのマクロは、実行後に作ったフォルダを開いてくれると、
より使い勝手の良いマクロになります。

そのコードがこちら。

Sub 選択セルからフォルダを一括作成する()
    Dim 親フォルダ As String
    親フォルダ = ThisWorkbook.Path & "\作成フォルダ集_" & Format(Now, "yyyymmddhhmm")
    MkDir 親フォルダ
    Call フォルダを一括作成する(Selection, 親フォルダ)
    Call フォルダをエクスプローラーで開く(親フォルダ)
End Sub

Function フォルダをエクスプローラーで開く(指定フォルダパス As String) As Boolean
    If Dir(指定フォルダパス, vbDirectory) <> "" Then
        Shell "C:\windows\explorer.exe " & 指定フォルダパス & "\", vbNormalFocus
        フォルダをエクスプローラーで開く = True
    End If
End Function

　
フォルダをエクスプローラーで開くコードを追加しました。

こちらも使いまわせるよう、汎用関数として作っています。

このようにちょっとしたカスタマイズをするだけで、
汎用マクロの使い勝手がとてもよくなります。

ちょっとした操作でも見逃さず、気の利くマクロを作っていきましょう。