【VBAマクロ(Excel)】サブフォルダ(下階層フォルダ)への再帰的処理【Office】

Dim cnt As Long
Dim tExcelN As String

Sub folderProc()

    On Error GoTo myError
    
    '画面の描画OFFにする
    Application.ScreenUpdating = False
    'アラートを非表示にする
    Application.DisplayAlerts = False
    
    Dim FSO As Object, f As Object
    Dim Path As String
    tExcelN = ThisWorkbook.Name
    cnt = 0
    
    '対象フォルダを選択する
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = True Then
            Path = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    '再帰的処理
    Call recurProc(Path)
    
    Set FSO = Nothing
    MsgBox (cnt & "ファイル 処理完了")
    Exit Sub
    
myError:
  MsgBox ("エラー内容：" & Err.Description)
 
End Sub

Function recurProc(Path)

    Set FSO = CreateObject("Scripting.FileSystemObject")

    For Each f In FSO.GetFolder(Path).Files
      
        '各ファイルへ処理実行
        Call fileProc(f)
        cnt = cnt + 1
        
    Next f
    
    'サブフォルダがあれば再帰的に処理
    For Each d In FSO.GetFolder(Path).SubFolders
        Call recurProc(d.Path)
    Next d
    
End Function

Function fileProc(f)

    'このExcel自身への処理はskip
    If f <> tExcelN Then
    
        'ここへ各ファイルへ実行したい処理を記述する
        Debug.Print f
        
        'Excelへのみ処理をしたい場合は以下の通り拡張子で条件分岐させる
        'If Right(f, 4) = ".xls" Or Right(f, 5) = ".xlsx" Or Right(f, 5) = ".xlsm" Then
        '    Debug.Print f
        'End If
    
    End If

End Function