どうもマサヤです！
さて今回は、「このフォルダ配下を全部取得して、階層化して、ハイパーリンクもつけたい！」といった、わがままな要望を叶えるコードをお届けします。
仕事の説明資料の一つとして、フォルダを階層毎で表示して各フォルダ・ファイルを直接開けるようリンクを貼るといった仕事がたまにあるんですよね。その度にコードを書くのが面倒なのでVBAでサクッとコピペ解決できるようにしました！
では、見ていきましょう！
VBA コピペで使える！特定フォルダのファイル一覧を一括取得するコード
「特定フォルダのファイル一覧を一括で取得したい！」 「フォルダの場所を指定したら、配下のファイル名を一括で取得してくれるコードがあればなぁ～」 そんな、あなたと私のためにコピペで使えるコードを紹介します！
mmm-program.com
2021.04.12
VBA コピペで使える！好きな場所にフォルダを一括で作成するコード
コピペで簡単にできる！好きな場所にフォルダを複数・一括で作成でる方法！
mmm-program.com
2022.03.05
【動画】コード実行した結果はこんな感じ
「思っていた形と違う！」ではいけませんので、まずはコードの実行結果を動画でご覧ください。
【これをコピペ！】フォルダ内を全取得し、階層・リンク化するコード
では、コードを紹介します。
Public findPath As String
Sub GetFolderList()
Dim fso As Object
Dim cf As Variant
Dim oRow, oCol As Integer
findPath = "C:\Users\masay\Google ドライブ\ブログ" '←取得したいフォルダパスを指定する
oRow = 2 '←出力開始の行を指定
oCol = 2 '←出力開始の列を指定
'指定フォルダを出力
Cells(oRow, oCol) = findPath
ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, oCol), Address:=findPath
Set fso = CreateObject("Scripting.FileSystemObject")
Set cf = fso.GetFolder(findPath)
'フォルダ全探査
Call GetSubFolder(cf, oRow + 1, oCol)
End Sub
'===============================================================================
' フォルダ単位で全探査
'===============================================================================
Sub GetSubFolder(cf, oRow, oCol)
'ファイル出力処理
For Each f In cf.Files
fLevel = UBound(Split(Replace(f.Path, findPath, ""), "\"))
Cells(oRow, oCol + fLevel) = f.Name
Call lineDraw(oRow, oCol, fLevel) '罫線を引く
ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, fLevel + oCol), Address:=f.Path 'ハイパーリンク化
oRow = oRow + 1
Next
'サブフォルダ処理
For Each f In cf.SubFolders
fLevel = UBound(Split(Replace(f.Path, findPath, ""), "\"))
Cells(oRow, oCol + fLevel) = f.Name
Call lineDraw(oRow, oCol, fLevel) '罫線を引く
ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, fLevel + oCol), Address:=f.Path 'ハイパーリンク化
oRow = oRow + 1
Call GetSubFolder(f, oRow, oCol) '再帰呼出
Next
End Sub
Sub lineDraw(oRow, oCol, fLevel) '罫線を引く
For i = oCol + fLevel - 1 To oCol Step -1
If i = oCol + fLevel - 1 Then
Cells(oRow, i) = ChrW(&H23BF)
Else
Cells(oRow, i) = "│"
End If
Cells(oRow, i).HorizontalAlignment = xlCenter
Next
End Sub
細かい所は後述しますが、9行目のフォルダパス部分を取得したいフォルダパスに変更すれば利用できます。使用方法が解る方は、コードを自分好みにカスタマイズして利用してくださいね。
ハイパーリンクが不要の場合
下記コード部分（16・38・48行目）を削除 or コメント化することでハイパーリンク化しなくなります。
ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, oCol), Address:=findPath
ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, fLevel + oCol), Address:=f.Path 'ハイパーリンク化
罫線が不要の場合
下記コード部分（37・47行目）を削除 or コメント化することで罫線（⎿・│）が無くなります。
Call lineDraw(oRow, oCol, fLevel) '罫線を引く
コードの使用手順
VBE展開⇒標準モジュール追加⇒コードコピペで完了です。動画や一連流れはこちらで確認できます。（別コードをコピーしていますが操作は一緒です）
まとめ
サブフォルダを含めた全フォルダ・ファイルを階層別に出力するコードをお届けしました！
ファイルが多くなるほどこの作業は時間を要し、ファイル数が数十個になれば数時間は余裕でかかります。単純作業で本当に時間の浪費なので、コードを使ってサクッと終わらせましょう！
そして、浮いた時間を他の仕事やプライベートに使ってくださいね。
コメント
こちらのコード、大変助かりました。ありがとうございます！
f、ｆLevelのDimがされてなかったので、利用時には自分で追加して実行しました。
とても良さそうなツール、コードなのですが、躓いています。
親フォルダの直下にはファイルが無く、サブフォルダが幾つかあり、それらにはファイルが入っています。
1つめのサブフォルダ内を抽出後、次のサブフォルダに移る際にエラーが発生します。
実行時エラー424
オブジェクトが必要です。
エラー箇所は
For Each f In cf.SubFolders
いろいろググりましたが、よく分からず・・・。
ご指導、よろしくお願いいたします。
コードありがとうございます。
VBA初心者なので、いろんなところのコードをいただいて試したんですが、
なぜかうまく走らず、原因も分からずｗ
こちらのコードは分かりやすく整理されていて、一発で使えました。
自分仕様にアレンジもでき、その際もエラーなし。
素晴らしいです。
初心者って、一回エラーが出ると、なにをどうしていいかわからなくなっちゃうんですよね。
これからもよろしくお願いします。
めちゃくちゃ助かりました。世の中には天才っているんですね。。。（尊敬しかない）
コメントされた方がいらっしゃいましたが、
「Sub GetSubFolder(cf, oRow, oCol)」内で
Dim f As Folder, fLevel As Longを追加し、
「Sub lineDraw(oRow, oCol, fLevel) 」内で
Dim i as longを追加させていただきました。
（で良いのですかね。。。）
本当にありがとうございました！