用途：　指定したフォルダーとサブフォルダーを含めて特定のファイルを探す

 

下記コードは、サブフォルダー、さらにこのサブフォルダー、さらに・・・と何層でもどんどん深いサブフォルダーを自動的に探します。

 

Sub sFolderSearch(ByVal strSFName0 As String, ByVal ShN As String)
    Dim myFolder As Folder
    Dim mySubFolder As Folder
    Dim strSFName As Variant
    Dim FSO As Object
    Dim Row As Long

 

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myFolder = Fso.GetFolder(strSFName0)
       
    With myFolder
        If .SubFolders.Count > 0 Then
            For Each mySubFolder In .SubFolders
                '見つかったサブフォルダを書き込む
                strSFName = strSFName0 & "\" & mySubFolder.Name
                Row = ThisWorkbook.Sheets(ShN).Cells(65536, 1).End(xlUp).Offset(1, 0).Row
                ThisWorkbook.Sheets(ShN).Cells(Row, 1) = strSFName
                Row = Row + 1
                If Row > 1001 Then     'サブフォルダーの個数が1000個を超えたら強制終了
                    End
                End If
                '再帰的に関数を呼び出し
                Call sFolderSearch(strSFName, ShN)
            Next
        End If
    End With

 

    Set FSO = Nothing

End Sub