【Excel】サブフォルダ一覧【VBA】

　対象フォルダのサブフォルダ一覧をワークシートに出力するコード。

Sub MakeFolderList()
    Set sf = CreateObject("Scripting.FileSystemObject").GetFolder("C:\").SubFolders
    Dim x: ReDim x(sf.Count, 1)
    For Each f In sf
        x(i, 0) = f.Name
        i = i + 1
    Next
    Range("A1:A" & sf.Count) = x
End Sub

　対象フォルダを変えたければ"C:\"の所を書き換えればOK。

　もしA1セル以下ではなく、C3セル以下にリストを出力したい場合は、最後の行を"Range("C3:C" & sf.Count + 2) = x"のように書き換えればOK。

---

　このコードを考えるにあたって、サンプルとして一万個のダミーフォルダを作成・削除したり、処理時間を測定したのが以下。

Public StartTime As Double
Public EndTime As Double
Const TargetFolder = "C:\test"

Sub TimerStart()
    StartTime = Timer
End Sub

Sub TimerStop()
    EndTime = Timer
    MsgBox (EndTime - StartTime & " 秒")
End Sub

Sub MakeDummyFolder()
    Call TimerStart         '---- 測定開始
    Set fs = CreateObject("Scripting.FileSystemObject")
    For i = 0 To 9999
        fs.CreateFolder (TargetFolder & _
                         "\_dummy_" & _
                         Format(i, "0000"))
    Next i
    Set fs = Nothing
    Call TimerStop          '---- 約3.5～10秒
End Sub

Sub MakeFolderListA()
    [A:A].Clear
    Call TimerStart         '---- 測定開始
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set sf = fs.GetFolder(TargetFolder).SubFolders
    i = 1
    For Each f In sf
        Cells(i, 1) = f.Name
        i = i + 1
    Next
    Set sf = Nothing
    Set fs = Nothing
    Call TimerStop          '---- 約0～8秒???
                            'フォルダがなければ当然0秒
End Sub

Sub MakeFolderListB()
    [B:B].Clear
    Call TimerStart         '---- 測定開始
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set sf = fs.GetFolder(TargetFolder).SubFolders
    Dim x As Variant
    ReDim x(sf.Count, 1)  '<-- 配列のリサイズ
    For Each f In sf
        x(i, 0) = f.Name
        i = i + 1
    Next
    Range("B1:B" & sf.Count) = x
    Set sf = Nothing
    Set fs = Nothing
    Call TimerStop          '---- 約0～6秒???
                            'Aより少しだけ速い
End Sub

Sub DeleteFolders()
    Call TimerStart         '---- 測定開始
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set sf = fs.GetFolder(TargetFolder).SubFolders
    For Each f In sf
        If f.Name Like "*_dummy_*" Then
            f.Delete      '<-- ※注意!フォルダ全削除
        End If
    Next
    Set sf = Nothing
    Set fs = Nothing
    Call TimerStop          '---- 約4～10秒
End Sub