フォルダにあるファイルの個数を数える

　パソコンをあれこれ使っているとファイルの数も増えてフォルダの階層も深くなります。空のフォルダなどもたくさんになってきます。そういう時、整理をしようと思うのですが、やみくもに調べても結構手間がかかります。そういうときの参考になるように、フォルダにあるファイルの個数を数えるVBAを作りました。
　なぜExcel VBAでやるかというと、シートにデータを落としてリストにできるからです。
　調べている内容は、そのフォルダに含まれる、サブフォルダの個数とファイルの個数です。サブフォルダに対しても調べていきます。
　整理をするならフォルダやファイルを消す機能をつけるべきですが、間違って必要なものを消す危険もあるので、公開するものにはその機能はつけていません。削除等をする場合は、サブフォルダを調べた時、そこに含まれるサブフォルダの個数とファイルの個数がゼロなら、そのサブフォルダを削除するなどの処理を追加すれば実現できます。階層の深いとこらから消していかないと消し残りが生じますから、工夫は必要です。
　処理は結構時間がかかります。これはおそらくExcelだから遅いのではなく、OSとディスクの速さによると思います。試したところサブフォルダの数が13個で0.8秒（62msec/folder）、4401個で57.4秒（130msec/folder）でした。

結果の例

VBAのコードは以下です。

Public Sub FolderCounter()
Const Title As String = "Folder,Num of SubFolder,Num of file"

Dim tt0 As Double, tt1 As Double
Application.ScreenUpdating = False

Dim ePath As String
ePath = FileDialog(msoFileDialogFolderPicker)

tt0 = Timer

Dim dicFolder As Dictionary
Set dicFolder = GetFolderListDic(ePath)

Dim buff As Variant
buff = GetArrayFromDic(dicFolder)

ClearSht
WriteTitleToSht Split(Title, ","), , 1, 1
WriteArrayToSht buff, , 2, 1

tt1 = Timer
Debug.Print tt1 - tt0

Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

フォルダを探す
Private Function GetFolderListDic(sPath As String) As Dictionary
Dim fso As New FileSystemObject
Dim objFolder As Folder
Dim dicFolder As New Dictionary
Dim dicSubFolder As Dictionary

Application.StatusBar = sPath
DoEvents

'sPathのサブフォルダ取得
For Each objFolder In fso.GetFolder(sPath).SubFolders
    '取得したサブフォルダとそこにあるファイルの個数を辞書に登録
    dicFolder(objFolder.Path) = Array(objFolder.SubFolders.Count, objFolder.Files.Count)
    
    Set dicSubFolder = GetFolderListDic(objFolder.Path)
    ConcDic dicFolder, dicSubFolder
Next
Set fso = Nothing
Set GetFolderListDic = dicFolder
Set dicFolder = Nothing
Set dicSubFolder = Nothing
End Function

'DstDicとOrgDicをDstDicに結合する。同じKeyがある場合はOrgDicのものが残る。
Private Sub ConcDic(DstDic As Dictionary, OrgDic As Dictionary)
Dim keywd As Variant
For Each keywd In OrgDic.Keys
DstDic(keywd) = OrgDic(keywd)
Next
End Sub

'ファイルダイアログを表示する
Private Function FileDialog(fdt As MsoFileDialogType) As String
Dim res As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = True Then
res = .SelectedItems(1)
End If
End With
FileDialog = res
End Function

'辞書を配列に変換する
Private Function GetArrayFromDic(dic As Dictionary) As Variant
Dim keywd As Variant
Dim res As Variant
Dim i As Long
Dim j As Long
i = 0
For Each keywd In dic.Keys
    If i = 0 Then
        ReDim res(dic.Count - 1, UBound(dic(keywd)) + 1)
    End If
    res(i, 0) = keywd
    For j = 0 To UBound(dic(keywd))
        res(i, j + 1) = dic(keywd)(j)
    Next
    i = i + 1
Next
GetArrayFromDic = res
End Function

'シートに配列の内容を書く
Private Sub WriteTitleToSht(buff As Variant, Optional sht As String = "", Optional srow As Long = 1, Optional scol As Long = 1)
If sht = "" Then
sht = ActiveSheet.Name
End If

With Worksheets(sht)
    .Activate
    .Cells(srow, scol).Resize(1, UBound(buff, 1) - LBound(buff, 1) + 1) = buff
End With

End Sub

'シートに配列の内容を書く
Private Sub WriteArrayToSht(buff As Variant, Optional sht As String = "", Optional srow As Long = 1, Optional scol As Long = 1)
If sht = "" Then
sht = ActiveSheet.Name
End If

With Worksheets(sht)
    .Activate
    .Cells(srow, scol).Resize(UBound(buff, 1) - LBound(buff, 1) + 1, UBound(buff, 2) - LBound(buff, 2) + 1) = buff
End With
End Sub

'シートの内容を削除する
Private Sub ClearSht(Optional sht As String = "")
If sht = "" Then
sht = ActiveSheet.Name
End If

With Worksheets(sht)
    .Cells.ClearContents
End With
End Sub