フォルダ構造を一覧にするExcel VBA

Posted on2020年10月29日投稿者: バイリンガルネットワークエンジニア　のぽた

仕事してて、フォルダ構造と収納されているファイルを一覧にしたいなって思ったことないですか？

Excel VBAで作っておきました。

どうぞ。
使ってください。
編集しないといけない点は、変数”Path”の値だけです。

14年ぶりにプログラミング書いてるので、リファクタリングしてくれる人募集中ですm(__)m

Dim numOfDelimiter As Long

Sub mainFFs()

   'Declare
   Dim subFolders As Object
   Dim Path As String
   Dim rowP As Long
   Dim culP As Long
   Dim numOfSubF As Long
   Dim buf As String

   'Set values

   Path = "C:\Users\" 'ここに一番上のフォルダを指定してくださいね
   rowP = 1
   culP = 1

   'Pathに \ が何個あるか数える
   numOfDelimiter = UBound(Split(Path, "\"))

   '指定したフォルダだけ、書いてしまう
   Cells(1, 1) = Path
   culP = culP + 1
   buf = Dir(Path &amp; "\*.*")
   Do While buf &lt;&gt; ""
       Cells(rowP, culP) = buf
       rowP = rowP + 1
       buf = Dir()
   Loop

   Call writeSubFFs(Path, culP, rowP)

End Sub

Sub writeSubFFs(Path As String, culP As Long, rowP As Long)

   '階層の調整
   Dim curPath As Long '文字カウント数
   curPath = UBound(Split(Path, "\"))

   If curPath &lt;= numOfDelimiter + 1 Then
       culP = 3
   Else
       culP = culP + 1
   End If

   '*** Process ****

   '①フォルダ取得
   Set subFolders = CreateObject("Scripting.FileSystemObject").GetFolder(Path).subFolders

   For Each subFolders In subFolders

   '②フォルダ記載

       Path = subFolders.Path
       Cells(rowP, culP) = Path

   '③ファイル取得
       culP = culP + 1
       On Error Resume Next
       buf = Dir(Path &amp; "\*.*")
   '④ファイル記載
       Do While buf &lt;&gt; ""
           Cells(rowP, culP) = buf
           rowP = rowP + 1
           buf = Dir()
       Loop


       culP = culP - 1
       rowP = rowP + 1

       Call writeSubFFs(Path, culP, rowP)

   Next subFolders
End Sub

因みに、writeSubFFsは自身を再起してます。
（下から４行目のCallで）
理由は、再起しないとSubフォルダ１階層分しか取得できなかったため。

今後の応用としては、パスをリンクにしてみたり、2個のHDDの差分のみを同期するみたいなファイルの前段の処理として利用したり（車輪再発名しそうな予感）、書き出す対象ファイルに条件を付けて、欲しいファイルのみ記載したりなど、色々できますよね。

注意点：
　Cドライブから実行すると、
　私の環境だと、とんでもない量のファイルになりそうでした。
　（以下は、45万ファイル検出くらいで処理を止めました。の図）
　そこまで検出したくない場合は、対象ファイルを限定するなり、行のカウンターに制限を設けるなりした方が良いかもです。