VBAでフォルダツリー内のファイル数を一括で調べる

フォルダツリー内のサブフォルダに.xlsx、.txtなどのデータがあるか、あれば何個入っているかを一気に知りたい時ありませんか？
通常はExplorerで直接フォルダを見に行きますが、ツリーの枝が多いと面倒ですし、メモしていないとだんだん分からなくなってきます。。。
フリーソフトをインストールしなくても簡易的に調べられるようにマクロを作ってみました。

#コード

CountFilesInSubDir.bas

Option Explicit
                                                                  
Public Const ADR_ROOT       As String = "B2"        ' ルートフォルダ格納セル(controlシート)
Public Const ADR_FOL_ROOT   As String = "B2"        ' ルートフォルダ格納セル(resultsシート)
Public Const ADR_ST_CNT     As String = "A5"        ' カウント結果格納開始セル(resultsシート)
Public Const SHT_CTRL       As String = "control"   ' controlシート
Public Const SHT_RSLT       As String = "results"   ' resultsシート(結果出力シート)
Public rPath                As String               ' ルートフォルダパス
Public sep                  As String               ' パス区切り記号(\)
Public target               As String               ' カウント対象ファイル種類
Public cnt                  As Integer              ' 対象ファイル数
Public ofstRow              As Integer              ' resultsシートインクリメント用変数

Sub CountFilesInSubDir()
'*****************************************************
' メインメソッド
'*****************************************************
    Dim csh, rsh As Object
    Dim stAdd, enRsltAdd As String
    
    Set csh = Sheets(SHT_CTRL)
    Set rsh = Sheets(SHT_RSLT)
    stAdd = ADR_ST_CNT
    rPath = csh.Range(ADR_ROOT).Value
    target = csh.Range(ADR_ROOT).Offset(1, 0).Value
    sep = Application.PathSeparator
    ofstRow = 0
    rsh.Range(ADR_FOL_ROOT).Value = rPath
    rsh.Range(ADR_FOL_ROOT).Offset(1, 0).Value = target
    enRsltAdd = rsh.Cells.SpecialCells(xlCellTypeLastCell).Address(False, False, xlA1)
    rsh.Range(ADR_ST_CNT & ":" & enRsltAdd).ClearContents
    
    '---- サブフォルダ検索
    Call SearchSubFolder(rPath)
    
End Sub

Sub SearchSubFolder(Path As String)
'*****************************************************
' サブフォルダを再帰的に検索するメソッド
'*****************************************************
    Dim buf As String
    Dim f, rsh As Object
    Set rsh = Sheets(SHT_RSLT)
    
    '---- フォルダ内検索
    buf = Dir(Path & sep & target)
    Do While buf <> ""
        cnt = cnt + 1
        buf = Dir()
    Loop
    '---- 結果出力
    With rsh.Range(ADR_ST_CNT)
        .Offset(ofstRow, 0).Value = cnt
        If Path = rPath Then
            .Offset(ofstRow, 1).Value = "(ルートフォルダ)"
        Else
            .Offset(ofstRow, 1).Value = Replace(Path, rPath & sep, "")
        End If
        If cnt > 0 Then
            '---- ファイルがある場合、フォルダへのリンク挿入
            rsh.Hyperlinks.Add _
                anchor:=.Offset(ofstRow, 1), _
                Address:=Path
        End If
    End With
    ofstRow = ofstRow + 1
    
    '---- サブフォルダ検索(再帰処理)
    With CreateObject("Scripting.FileSystemObject")
        cnt = 0
        For Each f In .GetFolder(Path).SubFolders
            Call SearchSubFolder(f.Path)
        Next f
    End With
    
End Sub

Sub SelectFolder()
'*****************************************************
' ルートフォルダを選択するメソッド
'*****************************************************
    Dim csh As Object
    Set csh = Sheets(SHT_CTRL)
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            csh.Range(ADR_ROOT).Value = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
End Sub

#Excelシート

• controlシート
  
• resultsシート(結果出力シート)
  

#前準備

1. 任意名の.xlsmを作成し、"control","results"シートを作成する。（シート内設定詳細は画像を参照）
2. コードを標準モジュールに貼り付ける。
3. controlシートに実行ボタンと...ボタンを作成し、実行ボタンにCountFilesInSubDir、...ボタンにSelectFolderを登録する。

#使用方法

1. 検索対処のルートフォルダを選択する。
2. 検索対象ファイル種類を入力する。*.xls* のようにワイルドカード使用可。
3. 実行ボタンを押す。

→resultsシートに各フォルダのカウント結果が出力されます。ファイルがある場合はフォルダへのリンクが挿入されます。

#解説
作成の動機は単にフォルダ内のファイルがいくつあるかを知りたかった、というものなので、ファイル名一覧表示機能は実装していません。フォルダへのリンクを挿入したので、リンクを押すと該当フォルダが開き、中身を確認できます。(地味に便利かも！と自画自賛。。。)

#参照サイト
VBA マクロ セルにハイパーリンクを設定する（気ままにエクセルVBA）
サブフォルダを含めてファイル一覧を取得する（Dir関数の再帰呼び出し）