Option Explicit
 
    Dim dicT As Object          '連想配列 キー：フォルダ名 値：行番号
    Dim dicN As Object          '連想配列 キー：フォルダ名 値：検出時の連番
    Dim ws As Worksheet         '処理対象シート
Public Sub フォルダ検索()
    Dim lastrow As Long         '最終行
    Dim lastcol As Long         '最終列
    Dim wrow As Long            '行番号
    Dim folder As String        'フォルダー名
    Dim t0 As Double            '開始時間
    Dim t1 As Double            '終了時間
    Set dicT = CreateObject("Scripting.Dictionary")     ' 連想配列の定義
    Set dicN = CreateObject("Scripting.Dictionary")     ' 連想配列の定義
    dicT.CompareMode = vbTextCompare
    dicN.CompareMode = vbTextCompare
    Set ws = Worksheets("フォルダ検索")
    lastrow = ws.Cells(Rows.count, "A").End(xlUp).Row   'A列の最終行取得
    If lastrow < 2 Then Exit Sub
    '検索対象のフォルダ名を取得し、連想配列に格納する
    For wrow = 2 To lastrow
        folder = ws.Cells(wrow, "A").Value
        'フォルダ名が空欄はエラー
        If folder = "" Then
            MsgBox ("フォルダ名が空白")
            ws.Activate
            ws.Cells(wrow, "A").Select
            Exit Sub
        End If
        'フォルダ名が連想配列に未登録なら、連想配列に登録する
        If dicT.exists(folder) = False Then
            dicT(folder) = wrow
            dicN(folder) = 0
        Else
        'フォルダ名が連想配列に登録済みならエラー
            MsgBox (folder & "が重複")
            ws.Activate
            ws.Cells(wrow, "A").Select
            Exit Sub
        End If
        '当該行のB列～最終列迄をクリアする
        lastcol = ws.Cells(wrow, Columns.count).End(xlToLeft).Column   'wrow行目の最終列を求める
        ws.Cells(wrow, "B").Value = 0
        If lastcol > 2 Then
            ws.Cells(wrow, "C").Resize(1, lastcol - 2).Value = ""
        End If
    Next
    t0 = Timer
    folder = "C:"
    Call FindSubfolders(folder)     'Cドライブの検索
    folder = "D:"
    Call FindSubfolders(folder)     'Dドライブの検索
    t1 = Timer
    Application.StatusBar = False   'ステータスバーのクリア
    MsgBox ("完了 処理時間=" & (t1 - t0) & "秒")
End Sub
'指定フォルダー内の検索（再帰処理）
Private Sub FindSubfolders(ByVal folder As String)
    Dim fname As String                 'フォルダ名
    Dim fnames() As String              'フォルダ名の配列
    Dim fcount As Long: fcount = 0      'フォルダ数
    Dim i As Long
    Dim wrow As Long                    '行番号
    Dim fno As Long                     'フォルダ検出時の連番
 
    On Error GoTo ERROR99               'アクセス件等でエラーが発生した場合は、当該フォルダの処理を打ち切る
    Application.StatusBar = folder      'ステータスバーに指定フォルダ名を表示
    '指定フォルダ内のフォルダを全て取得し、配列に格納する
    fname = Dir(folder & "\*", vbDirectory)
    Do While fname <> ""
        '取得したファイルがフォルダなら、以下の処理を行う
        If IsFolder(folder, fname) = True Then
            '取得したフォルダ名が検索対象のフォルダなら、検知件数に1加算し、そのフォルダ名を結果欄に出力する
            If dicT.exists(fname) = True Then
                fno = dicN(fname) + 1
                dicN(fname) = fno
                wrow = dicT(fname)
                ws.Cells(wrow, 2).Value = ws.Cells(wrow, 2).Value + 1
                ws.Cells(wrow, 2 + fno).Value = folder & "\" & fname
            End If
            '取得したフォルダ名を配列に格納する
            ReDim Preserve fnames(fcount)
            fnames(fcount) = fname
            fcount = fcount + 1
        End If
        fname = Dir()
    Loop
    '取得したフォルダ名の配列を順に処理する
    For i = 0 To fcount - 1
        Dim newfolder As String
        newfolder = folder & "\" & fnames(i)
        '当該フォルダのその直下のフォルダを検索する
        Call FindSubfolders(newfolder)
    Next
    Exit Sub
ERROR99:
    Err.Clear
End Sub
'フォルダかフォルダ以外かのチェック
'戻り値 True:フォルダ False:フォルダ以外
Private Function IsFolder(ByVal folder As String, ByVal fname As String) As Boolean
    IsFolder = False
    Dim attr As Long
    'フォルダ名が"."又は".."は除く
    If fname = "." Then Exit Function
    If fname = ".." Then Exit Function
    '属性を取得し、vbDirectoryならフォルダとする
    attr = GetAttr(folder & "\" & fname)
    If (attr And vbDirectory) <> vbDirectory Then Exit Function
    IsFolder = True
End Function