自分用メモ_VBA 指定のフォルダ配下のファイルの値の個数を一覧出力

Sub CountValuesInDColumn_Recursive_AllFiles()
    Dim folderPath As String

    ' 処理対象のフォルダ（変更してください）
    folderPath = "C:\Your\Folder\Path\"

    ' イミディエイトウィンドウの内容をクリア
    Debug.Print "ファイル名, 値の個数"

    ' 再帰的にフォルダを探索
    ProcessFolderAndFiles folderPath

    ' 完了メッセージ
    Debug.Print "処理が完了しました。"
End Sub

Sub ProcessFolderAndFiles(folderPath As String)
    Dim fileName As String
    Dim subFolder As Object
    Dim fso As Object
    Dim folder As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim nonEmptyCount As Long

    ' フォルダパスの末尾に\がない場合、追加
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\"
    End If

    ' ファイルシステムオブジェクトの作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)

    ' 現在のフォルダ内の「AAA_」で始まる .xlsx ファイルを処理
    fileName = Dir(folderPath & "AAA_*.xlsx")
    Do While fileName <> ""
        ' ファイルを開く
        Set wb = Workbooks.Open(folderPath & fileName)

        ' 「第1回目」シートが存在するか確認
        On Error Resume Next
        Set ws = wb.Sheets("第1回目")
        On Error GoTo 0

        If Not ws Is Nothing Then
            ' D列の最終行を取得
            lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

            ' D列の値の個数をカウント（空白を除外）
            nonEmptyCount = Application.WorksheetFunction.CountA(ws.Range("D1:D" & lastRow))

            ' 結果を出力
            Debug.Print fileName & ", " & nonEmptyCount
        Else
            ' 「第1回目」シートが存在しない場合のメッセージ
            Debug.Print fileName & ", シート「第1回目」が存在しません"
        End If

        ' ファイルを閉じる（保存せず）
        wb.Close SaveChanges:=False

        ' 次のファイルに進む
        fileName = Dir
    Loop

    ' サブフォルダを再帰的に処理
    For Each subFolder In folder.SubFolders
        ProcessFolderAndFiles subFolder.Path
    Next subFolder
End Sub