フォルダ内のサブフォルダとファイルをリストアップ

この講座を含む定額コースや講座(単体)を購入すると閲覧できます

この動画を閲覧するには、「エクセルVBA外部連携講座」をご購入ください。

この講座を含む定額コースに参加するか、この講座を購入することで、講座を利用できるようになります。
定額コースに参加すると、そのコースの利用期間中はいつでも講座を利用できます。
講座を購入すると、いつでも講座を利用できます。

このページへの投稿/コメント

受講生さんの投稿

(投稿ID: 4523)  添付ファイルのダウンロード権限がありません

再帰呼出を利用してフォルダ構成を調査し、別フォルダにフォルダ構成のみをコピーするマクロです。やっと実現できました。(添削希望なし。)
Public Sub XCopy()
    Dim fmFol As String, toFol As String
    '参照元フォルダパスを文字列型変数に入れる
    fmFol = ThisWorkbook.Worksheets("XCopy").Range("B3").Value
    '参照先フォルダパスを文字列型変数に入れる
    toFol = ThisWorkbook.Worksheets("XCopy").Range("B6").Value

    If fmFol = toFol Then
        MsgBox "参照元と参照先のフォルダーパスが同一のため実行できません。"
        Exit Sub
    End If
   
   '参照元フォルダパスが\で終わる場合、終了
    If Right$(fmFol, 1) = "\" Then
        MsgBox "参照元フォルダを指定してください。"
        Exit Sub
    End If

    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject

    If Not (FSO.FolderExists(fmFol)) Then
        MsgBox "参照元フォルダパスが実在しません。"
        Exit Sub
    End If

    If Not (FSO.FolderExists(toFol)) Then
        MsgBox "参照先フォルダパスが実在しません。"
        Exit Sub
    End If

    '参照先フォルダパスが\で終わる場合、最後の\を除去
    If Right$(toFol, 1) = "\" Then
        toFol = Left$(toFol, Len(toFol) - 1)
    End If
      
    If MsgBox("フォルダ構成を参照元から参照先にコピーします。" & vbNewLine & _
        "よろしいですか?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
   
    Dim FolderCol As Collection    'Collectionオブジェクト
    Set FolderCol = New Collection 'インスタンス化

    '参照元フォルダ構成をサーチするサブプロシージャー呼出
    RecExplorer fmFol, FSO.GetFolder(fmFol), 0, FolderCol
    Application.StatusBar = False

    '参照先フォルダにトップフォルダ作成
    If Not (FSO.FolderExists(toFol & Mid$(fmFol, InStrRev(fmFol, "\")))) Then
        'フォルダが存在しない場合に作成
        FSO.CreateFolder (toFol & Mid$(fmFol, InStrRev(fmFol, "\")))
    End If
    
    '参照先フォルダに参照元フォルダ構成コピー
    Dim sFol As Variant
    On Error GoTo ErrCheck1
    For Each sFol In FolderCol 'Collectionオブジェクトから取り出す
        If Not (FSO.FolderExists(toFol & sFol)) Then
            'フォルダが存在しない場合に作成
            FSO.CreateFolder (toFol & sFol)
        End If
    Next sFol
    On Error GoTo 0 'エラー処理を通常に戻す

    Set FolderCol = Nothing
    Set FSO = Nothing
    
    MsgBox "フォルダ構成のコピー完了。"
    
    'Explorer起動
    CreateObject("Shell.Application").Open toFol & "\"
    Exit Sub
    
ErrCheck1:
    '実行時エラー「ファイルが見つかりません。」(53)は想定内なので無視。
    '実行時エラー「パスが見つかりません。」(76)は想定内なので無視。
    'それ以外はエラーを発生させる。
    If Err.Number <> 53 And Err.Number <> 76 Then
        Err.Raise Err.Number
    End If
    Debug.Print Err.Number
    Err.Clear
    Resume Next
End Sub

Private Sub RecExplorer(ByRef fmFol As String, _
                        ByRef f As Folder, _
                        ByVal n As Integer, _
                        ByRef Col As Collection)
    Application.StatusBar = String(n * 2, "-") & f.Name
    DoEvents
    
    Dim Subf As Folder
    On Error GoTo ErrCheck2
    For Each Subf In f.SubFolders
        '見つかったフォルダパスをCollectionオブジェクトに追加
        Col.Add Mid$(fmFol, InStrRev(fmFol, "\")) & Mid$(CStr(Subf), Len(fmFol) + 1)
        '再帰呼び出し
        RecExplorer fmFol, Subf, n + 1, Col
    Next Subf
    On Error GoTo 0 'エラー処理を通常に戻す
    Exit Sub
ErrCheck2:
    '実行時エラー「書き込みできません。」(70)は想定内なので無視。
    'それ以外はエラーを発生させる。
    If Err.Number <> 70 Then
        Err.Raise Err.Number
    End If
    Debug.Print Err.Number
    Err.Clear
    On Error GoTo 0 'エラー処理を通常に戻す
End Sub

2019年07月09日 05時29分

コメントするにはログインしてください

こんちゃんさんの投稿

(投稿ID: 3953)

FSO 概念を理解するのに時間かかりましたが、
非常に強力!
紙で管理していた帳票がエクセルだけでできちゃいました。(^^)v
フォルダにあるファイルを指定し、処理して保存する。
保存したら処理日を別のシートに入力。
まさにペーパーレス化!便利になります化!
管理も非常に楽になりました♪
ここまでできるのがなにより楽しいです!♪
2018年06月14日 08時58分

コメントするにはログインしてください

田中 宏明さんの投稿

(投稿ID: 3939)

今日は、指定フォルダーから下にある全サブフォルダーを検索し、条件にヒットしたファイル(ある文字が含まれたファイル)のみを1つのフォルダーに移動させるマクロを作成できました。
for each構文 , instr関数, 動的配列, 再帰呼出 の組み合わせで実現でき、感激です。 
2018年06月08日 06時00分

コメントするにはログインしてください

山田 将之さんの投稿

(投稿ID: 1882)

再帰がよくわかりませんでした。ここを何とか理解するよう頑張ります。
2016年01月10日 18時51分

コメントするにはログインしてください

この講座を含む定額コースや講座(単体)を購入すると閲覧できます

この動画を閲覧するには、「エクセルVBA外部連携講座」をご購入ください。