対象フォルダのサブフォルダ一覧をワークシートに出力するコード。
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
