特定ドライブ下の全フォルダパスを取得する

所謂再帰処理ですね。

コード

フォルダパスを出力させたいシートのシートモジュールに以下をコピペ。
で、GetFoldersを実行してもらえば、当該シートのA列にフォルダパスが出力されます。

Option Explicit
Private r As Long 'セルに出力させる際の行カウンター

Sub GetFolders()

    Const cnsRootDrv = "D"
    
    Dim fols As Object
    Dim fol  As Object
    
    r = 1
    
    Set fols = CreateObject("Scripting.FileSystemObject") _
                .GetDrive(cnsRootDrv).RootFolder.SubFolders
    
    If Not fols Is Nothing Then
        Call getFol(fols)
    Else
        MsgBox cnsRootDrv & "ドライブにはフォルダーが有りません!", vbExclamation
    End If
    
    Set fols = Nothing
    
End Sub
    
Sub getFol(argFol As Object)

    Dim objFSO  As Object
    Dim fol     As Variant
    Dim strPath As String
    Dim c       As Long

    On Error Resume Next
    
    For Each fol In argFol
        Me.Cells(r, "A").Value = fol.Path
        r = r + 1
        'そのフォルダ中にサブフォルダーが存在すれば再帰
        If fol.SubFolders.Count > 0 Then
            Call getFol(fol.SubFolders)
        End If
    Next fol
    
End Sub

getFolプロシージャでエラーを無視させてんのは、実行時エラー70が出て止まる事があったので。
エラーの内容は、対象のフォルダにロックがかかってる為、参照出来ないとかそんな理由っぽい。
ただ、実行結果には影響を与えてないっぽいので、とりあえず無視しときゃOKかなと…(；^ω^)