自動でフォルダを作成する

Question

前提・実現したいこと

あるフォルダの中に入っているフォルダ（下層部まで）を全て指定のフォルダ内に作成したいです
フォルダの作成場所はPC内だけでなく、サーバー上も想定しております

（例）

　テスト1　　⇒　テスト2　　⇒ テスト5　　⇒ テスト7

テスト1　　⇒　テスト2　　⇒ テスト6

テスト1　　⇒ テスト3

テスト1　　⇒ テスト4

C:\Users\〇〇〇\Documents\テスト1\テスト2
C:\Users\〇〇〇\Documents\テスト1\テスト3
C:\Users\〇〇〇\Documents\テスト1\テスト4
C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5
C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト6
C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5\テスト7

イメージは、下記のとおりです。　　　　　　
（1）フォルダを選ぶ
（2）（1）のパスをExcelに表示
（3）（1）のフォルダ一覧をExcelに作成
（4）フォルダを選ぶ
（5）（4）のフォルダに（3）のフォルダを作成

発生している問題・エラーメッセージ

(困っていること）

（3）です。

　http://www.fingeneersblog.com/1610/
↑
こちらのサイトを参照させていただいたのですが何もおこりません
どうやったらフォルダの一覧を取得できるようになるのでしょうか？

　B列に1次フォルダ、C列に2次フォルダ、D列に3次フォルダ・・・・
入力箇所はB13からで、階層フォルダは次の行に入力できるようになりたいです。

　ご指導頂けますでしょうか。
宜しくお願いいたします

該当のソースコード

[フォルダパス]は取得したいフォルダのパスを入力しました。

'--- サブフォルダのパス一覧を配列に取得する ---'
Public Sub GetAllSubFolderPath()

    '--- フォルダ一覧を取得したいフォルダのパス ---'
    Dim folderPath As String
    folderPath = "[フォルダパス]"


    '--- フォルダパスを取得する ---
    Dim folderList As Variant
    folderList = GetFolderPath(folderPath)

End Sub

'--- サブフォルダを再帰的に取得する関数 ---'
Public Function GetFolderPath(folderPath As String) As String()

    '--- ファイルシステムオブジェクト ---'
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    '--- フォルダ数を格納する変数 ---'
    Dim n As Variant
    n = fso.GetFolder(folderPath).SubFolders.Count
    
    Dim r As Long
    Dim c As Long
    Application.ScreenUpdating = False
    For r = 1 To UBound(folderList)
    fs = Split(Mid(folderList(r), Len(folderPath)), "\")
    For c = 1 To UBound(fs)
        Cells(r, c + 1).Value = fs(c)
    Next
    Next
Application.ScreenUpdating = True

    If (0 < n) Then
        '--- フォルダパスを格納する配列 ---'
        Dim str() As String
        ReDim str(1 To n)

        '--- フォルダパスを格納 ---'
        Dim i As Long
        Dim j As Long
        Dim m As Long
        i = 1
        Dim strTmp() As String

        'フォルダパスを指定してすべてのサブフォルダを取得
        Dim f As Object
        For Each f In fso.GetFolder(folderPath).SubFolders
            str(i) = f.Path

            strTmp = GetFolderPath(str(i))  '再帰的呼び出し
            If (Not IsEmptyArray(strTmp)) Then
                m = UBound(strTmp, 1)
            Else
                m = 0
            End If

            'サブフォルダ内にさらにフォルダがあればその分だけ配列を拡張
            n = UBound(str, 1)
            ReDim Preserve str(1 To n + m)
            For j = 1 To m
                str(i + j) = strTmp(j)
            Next j

            i = i + m + 1
        Next f
    End If

    GetFolderPath = str

End Function

'--- 配列が空かどうかを判定する関数 ---'
Public Function IsEmptyArray(arrayTmp As Variant) As Boolean
On Error GoTo ERROR_

    If (0 < UBound(arrayTmp, 1)) Then
        IsEmptyArray = False
    End If

    Exit Function

ERROR_:

    IsEmptyArray = True

End Function

Comments

[DreamTheater]

FOLDERPATHに定義されたシートにサブフォルダー一覧を作成するところまでは出来ていて、そのシートからサブフォルダーを生成する部分が全くできていないということですか？

[ttyp03]

どこまでできてて、あとなにができてないかがわかりません。
あとフォルダ構成の例とかもあるといいです。

[ichigo15]

コメントありがとうございます。
説明が不足しておりご迷惑をおかけしております。

投稿している構文は別で使用しているファイルリストを作成するものです。
まだフォルダ一覧は作成できておりません。

フォルダだけのパスを取得しようと作成中です。
そこからフォルダの一覧を作成し、一覧からフォルダを生成できればと考えております。
もちろん、フォルダ名だけが取得できればいいのですがやり方が分からないので・・・

ご指導宜しくお願い致します。

[ttyp03]

質問事項が多すぎる（大きすぎる）ので、わからないことの３～５を順番に質問していったほうがいいでしょう。
別の質問で「フォルダ一覧をExcelに作成する方法」を立ち上げ、更に実現したい処理の中でどこまでできていて何が分からないのかを質問するようにしてください。
この質問は残しておいてもいいですが、最後に解決した結果でも書いて自己解決にでもすればよいかと思います。

[ichigo15]

コメントありがとうございます。

質問はフォルダ一覧の書き出しだけに変更しました。
他の項目はなんとか自己解決できそうです。

もし解決点をご存じでしたらご指導宜しくお願いいたします。

[kaz.Suenaga]

どうも質問内容が把握しきれないのですが、指定したフォルダ以下のフォルダ一覧をExcelのシートに出力しつつ、別に指定したフォルダ内にそれらのフォルダを同じように作成したい、ということですか？

[ichigo15]

コメントありがとうございます。
説明が下手でご迷惑をおかけしております。
そのとおり、フォルダ一覧の取得とフォルダの作成です。

あるブック（以下ブックA）にマクロを設定して、
①選択したフォルダ内にあるフォルダ一覧（下層部まで）をブックAに作成する
②フォルダを作成したい場所を選択し、ブックAにあるフォルダ一覧よりフォルダを作成する

①で取得したもの全て②で作成しない場合があるので一度Excelに一覧を取得して、確認・修正後に
②を行いたいと思っております。

もしまだ分かりにくいようでしたらご連絡くださいませ。
よろしくお願いいたします。

Answer 1

回答としてあまり適切ではないと思うのですが、一通り動作するコードをあげておきます。

• フォルダ一覧作成: get_folder_list を実行
• フォルダ作成: create_folders を実行

でできるかと思います。
一覧は ActiveSheet 、フォルダリストの最初のセルは B2 を前提にしています。

これまでのソースをベースにしていないので理解しなおすことになるかと思いますが、読んでみてわからない点等あればコメントで再質問してください。

Option Explicit


' 起点フォルダを記載するセル
Private Const CELL_BASE_FOLDER As String = "B2"


' -------------------------------------------
' フォルダ一覧作成
' -------------------------------------------
' ---- 起動: フォルダ一覧作成
Sub get_folder_list()
    ' 起点とするフォルダを選択
    Dim base_folder_path As String
    base_folder_path = folder_pick("作成するフォルダ一覧の対象フォルダを指定してください。")
    
    ' フォルダが指定された場合処理開始
    If base_folder_path <> "" Then
        
        ' サブフォルダを再帰的に一覧取得
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        Dim folder_list As Variant      ' サブフォルダリスト（配列）
        get_sub_folders fso.GetFolder(base_folder_path), folder_list
        Set fso = Nothing
        
        ' シートに転記
        write_folder_list ActiveWorkbook.ActiveSheet, base_folder_path, folder_list
    Else
        ' フォルダ指定しなかった場合の動作
    End If
End Sub

' ---- 再帰的にサブフォルダを検索
'   TARGET:     検索対象のフォルダオブジェクト
'   arr:        フォルダリスト配列（参照渡し）
Private Sub get_sub_folders(TARGET As Object, ByRef arr As Variant)
    Dim sub_folder As Object
    
    For Each sub_folder In TARGET.SubFolders
        push_arr sub_folder.PATH, arr
        get_sub_folders sub_folder, arr
    Next
End Sub

' ---- シートにフォルダリストを出力
'   ws:                 出力するシート
'   base_folder_path:   ベースフォルダ
'   folder_list:        フォルダリスト配列
Private Sub write_folder_list(ws As Worksheet, base_folder_path As String, folder_list As Variant)
    Dim i As Long
    Dim j As Long
    Dim path_array As Variant
    
    ' 起点とするセル
    With ws.Range(CELL_BASE_FOLDER)
        ' ベースとしたフォルダをそのセルに記載
        .Value = base_folder_path
       
        ' 以下ループしながらセルに出力（offset で起点セルからの相対位置をずらしながら出力）
        For i = LBound(folder_list) To UBound(folder_list)
        
            ' 配列要素からベースフォルダ部分を削除し、残りを \ で分割して配列化
            path_array = Empty
            path_array = Split(Replace(folder_list(i), base_folder_path & "\", ""), "\")
            
            ' 念のために配列化されているかをチェック
            If IsArray(path_array) Then
                ' セルに記載
                .Offset(i - LBound(folder_list) + 1, 0).Value = base_folder_path
                For j = LBound(path_array) To UBound(path_array)
                    .Offset(i - LBound(folder_list) + 1, j - LBound(path_array) + 1).Value = path_array(j)
                Next
            End If
        Next
    End With
    
    Set ws = Nothing
End Sub



' -------------------------------------------
' フォルダ作成
' -------------------------------------------
' ---- 起動: フォルダ作成
Sub create_folders()
    
    ' 元とするシート
    Dim ws As Worksheet
    Set ws = ActiveWorkbook.ActiveSheet
    
    ' 作成先のフォルダを取得
    Dim dest_folder_path As String
    dest_folder_path = folder_pick("サブフォルダを作成するフォルダを指定してください。")
    
    ' 作成先のフォルダを指定された場合
    If dest_folder_path <> "" Then
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        ' 指定したフォルダ内が空でない場合は念のため終了
        If Dir(fso.BuildPath(dest_folder_path, "*")) <> "" Then
            MsgBox "指定したフォルダ内が空ではないようです。安全のため処理を中止します。", vbOKOnly, "中止"
            Exit Sub
        End If
        
        ' サブフォルダ作成
        ' =================================================
        ' Excelのシートからデータ取得
        With ws.Range(CELL_BASE_FOLDER)
            Dim target_path As String
            Dim i As Long   ' 相対行に相当
            Dim j As Long   ' 相対列に相当
            
            ' 行の初め（フォルダ一覧を作成した際の検索基点フォルダ名が入っているはず）が空になるまで行方向にループ
            i = 1
            Do Until .Offset(i, 0).Value = ""
                ' フォルダ作成する基点フォルダパスを設定
                target_path = dest_folder_path
                
                ' 列（＝フォルダ階層）がなくなるまで列方向にループ
                ' 列の上位からたどっているため、パスを追記しながらフォルダの存在をチェックしなければ作る、を繰り返す
                j = 1
                Do Until .Offset(i, j).Value = ""
                    target_path = fso.BuildPath(target_path, .Offset(i, j).Value)
                    If Not (fso.FolderExists(target_path)) Then MkDir target_path
                    j = j + 1
                Loop
                i = i + 1
            Loop
        End With
    
        Set fso = Nothing
        Set ws = Nothing
    Else
        ' フォルダ指定をキャンセルした場合の処理
    End If
End Sub




' -------------------------------------------
' 共通関数
' -------------------------------------------

' ---- フォルダ選択ダイアログ
Private Function folder_pick(Optional dialog_title As String = "") As String
    Dim tmpRet As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If dialog_title <> "" Then .Title = dialog_title
        If .Show = True Then
            tmpRet = .SelectedItems(1)
        Else
            tmpRet = ""
            MsgBox "処理を中止しました。", vbOKOnly, "中止"
        End If
    End With
    
    folder_pick = tmpRet
End Function


' ---- 配列の最後にデータ追加
Private Sub push_arr(DATA As Variant, ByRef arr As Variant)
    
    If IsArray(arr) Then
        ReDim Preserve arr(UBound(arr) + 1)
    Else
        ReDim arr(0)
    End If
    
    ' 配列に代入
    If IsObject(DATA) Then  ' データがオブジェクトの場合
        Set arr(UBound(arr)) = DATA
    Else                    ' データがオブジェクトではない場合
        arr(UBound(arr)) = DATA
    End If
End Sub

Comments

[ichigo15]

コメントありがとうございます。

タイムラグで今朝、回答を頂けたことを通知するメールを受信いたしました
すいません、入れ違いだったようです

自分ではパスを分解できず諦めておりましたが、とても勉強になりました。
感謝いたします。

Answer 2

前の質問ですが、ベストアンサーがついていなかったので回答させて頂きます。
まず、貴方の行いたいVBAでのフォルダ自動作成はCreateFolder関数と言う関数を呼ばないと作成されません。
しかし、この関数も再帰的にフォルダーを作成してくれる訳ではなく、
例えば、
C:\Users\〇〇〇\Documents\テスト1\テスト2
の場合、テスト2をまず作成しようとしてテスト1がないのでエラーになります。
上位の階層にフォルダがないと作成できないと言うことです。

その為、GetParentFolderName関数を使い上位の階層にフォルダがあるかをチェックしていく必要があります。そのチェックの為にFolderExists関数を利用しながら開発を行うと良いでしょう。

これらの関数はScripting.FileSystemObjectの中にあるので、自分で調べながら行ってみましょう。

Comments

[ichigo15]

コメントありがとうございます。

丁寧な説明でとても分かりやすかったです。
引続き勉強してみようと思います。

Answer 3

もしかして、

folderPath = "[フォルダパス]"

の、"[フォルダパス]"に設定している内容が間違っていて、folderPathが空っぽになっているんじゃないかと思いました。

今回の例でいうと、

folderPath = "C:\Users\〇〇〇\Documents\テスト1"

のように、検索開始位置のパスを指定しないとfolderPath配列ができません。

もし上記に問題がないようであれば、こちらの見当違いなので無視してください。

Comments

[ichigo15]

コメントありがとうございます。

該当のソースコードにも書いてはいるのですが
”[フォルダパス]は取得したいフォルダのパスを入力しました。”

エラーはないので書き出しができてないのではないかと思います。
もしご存じでしたら教えて頂けないでしょうか。
宜しくお願いいたします。

[kenshirou]

あれ？「該当のソースコード」は、こんなコードでしたっけ？
GetFolderPath(folderPath)を使って、folderPath配下のサブフォルダのパス（「C:\Users\〇〇〇\Documents\テスト1\テスト2」や「C:\Users\〇〇〇\Documents\テスト1\テスト3」）を取得し、これを使用して「...\テスト1\テスト2」を「テスト1」と「テスト2」のように分割するのであれば理解できるのですが...
上記「テスト1」「テスト2」の分割はGetFolderPath関数の中で行うべきことではないと思います。
本来であれば、Public Sub GetAllSubFolderPath()関数の
folderList = GetFolderPath(folderPath)
の下に、ttyp03様のコードを書けばよいと思います。
ただし、以下の注意が必要です。
・fs変数の定義(Dim)を忘れないこと。（厳密にはString()）
・前者のコードを使う場合、
　　fs = Split(Mid(folderList(r), Len(folderPath)), "\")
　ではなく、
　　fs = Split(Mid(folderList(r), Len(folderPath) +1), "\")
　のようにすること。

[ichigo15]

コメントありがとうございます。
私が教えて頂いたコードを挿入する場所を間違えているのだと思います

Dim As Stringでは「配列がありません」とエラーになりましたので
私はVariantにしました。

Answer 4

こんな感じですかねぇ。
GetFolderPathの下に入れてください。

Dim r As Long
Dim c As Long
Application.ScreenUpdating = False
For r = 1 To UBound(folderList)
    fs = Split(Mid(folderList(r), Len(folderPath)), "\")
    For c = 1 To UBound(fs)
        Cells(r, c + 1).Value = fs(c)
    Next
Next
Application.ScreenUpdating = True

上の処理はベタに処理しているので件数が多いと結構遅いです。
以下は配列化して高速化したものです。

Dim r As Long
Dim c As Long
ReDim tmp(UBound(folderList), 1) As Variant
Application.ScreenUpdating = False
For r = 1 To UBound(folderList)
    fs = Split(Mid(folderList(r), Len(folderPath) + 1), "\")
    If UBound(fs) > UBound(tmp, 2) Then
        ReDim Preserve tmp(UBound(tmp, 1), UBound(fs))
    End If
    For c = 0 To UBound(fs)
        tmp(r - 1, c) = fs(c)
    Next
Next
Range("B1").Resize(UBound(tmp, 1), UBound(tmp, 2)) = tmp
Application.ScreenUpdating = True

Comments

[ichigo15]

コメントありがとうございます。
少し教えて頂けないでしょうか？

Dim n As Variant
n = fso.GetFolder(folderPath).SubFolders.Count
の後に教えて頂いた構文を追加いたしました。

fsの定義をLongにして実行したら、UBoundの配列がありませんとなってしまいました

ご指導いただけないでしょうか
宜しくお願いいたします。

[ttyp03]

fsにはパスを\マークごとに区切った文字列の配列が入ります。
なのでLongにはできません。

[ttyp03]

「まだ回答を求めています」となっていますが、期待していた回答と違いましたか？

[ichigo15]

コメントありがとうございます。

能力が低いのでせっかく教えて頂いたコードを挿入しましたがエラーを回避できないでいます
なので希望していた通りかどうかがまだ分かっておりません

質問文を教えて頂いたコードを挿入したものに変更いたしました
挿入したコードでエラーが出ております
どのように修正したらよいか教えていただけないでしょうか
宜しくお願いいたします。

[ttyp03]

入れてるところが違いますね。
GetAllSubFolderPath関数でGetFolderPath関数を呼んでいる下の行に入れてください。

'--- フォルダパスを取得する ---
Dim folderList As Variant
folderList = GetFolderPath(folderPath)
ここに入れる
End Sub

補足
GetFolderPath関数でフォルダのリストが取得できているのは確認されているでしょう。
その関数の戻り値folderListを使ってシートに展開するという流れです。

[ichigo15]

コメントありがとうございます。
コードを挿入する場所を間違えておりました申し訳ございません。
違う方法でも最下層のフォルダ名しか取得できずに諦めておりました。

教えて頂いたコードで希望通りにフォルダ一覧を取得できることができました、感謝いたします。