下層のフォルダパス取得

2020/05/18

サブフォルダを含めたフォルダ一覧の取得

Dim cnt As Long
Dim temp_cnt As Integer


Sub 下層フォルダ取得(SearchPath As String)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSYstemObject")

    'フォルダ追加
    Cells(cnt, 1) = SearchPath
    cnt = cnt + 1

    'ステータスバー表示
    msg = cnt & "個のフォルダ発見。検索："
    If Len(SearchPath) < 150 Then '文字数制限対策
        Application.StatusBar = msg & SearchPath
    Else
        Application.StatusBar = msg & "（略）"
    End If

    '行数制限
    If cnt >= 65536 Then 'Excel2003 max.65536
        Application.StatusBar = False
        End
    End If

    'フリーズ回避
    temp_cnt = temp_cnt + 1
    If temp_cnt >= 100 Then
        temp_cnt = 0
        DoEvents
    End If

    'フォルダ取得
    For Each f In FSO.GetFolder(SearchPath).SubFolders
        '下層制限
        If StrCount(f.Path, "\") <= 15 Then
            Call 下層フォルダ取得(f.Path)
        End If
    Next f

End Sub


Sub リスト作成()
    '無効設定
    'Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    '元リスト削除
    Range("A1:B1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select

    'リスト作成
    cnt = 1
    temp_cnt = 1
    Call 下層フォルダ取得(ThisWorkbook.Path)

    '無効設定を戻す
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub


Function StrCount(Source As String, Target As String) As Long
    Dim n As Long, cnt As Long
    Do
        n = InStr(n + 1, Source, Target)
        If n = 0 Then
            Exit Do
        Else
            cnt = cnt + 1
        End If
    Loop
    StrCount = cnt
End Function