VBA コピペで使える!階層別で全フォルダ・ファイルを取得・リンク化するコード

この記事は約5分で読めます。

VBA フォルダ階層表示

どうもマサヤです!

さて今回は、「このフォルダ配下を全部取得して、階層化して、ハイパーリンクもつけたい!」といった、わがままな要望を叶えるコードをお届けします。

仕事の説明資料の一つとして、フォルダを階層毎で表示して各フォルダ・ファイルを直接開けるようリンクを貼るといった仕事がたまにあるんですよね。その度にコードを書くのが面倒なのでVBAでサクッとコピペ解決できるようにしました!

では、見ていきましょう!

スポンサーリンク

【動画】コード実行した結果はこんな感じ

「思っていた形と違う!」ではいけませんので、まずはコードの実行結果を動画でご覧ください。

全フォルダ階層別出力

【これをコピペ!】フォルダ内を全取得し、階層・リンク化するコード

では、コードを紹介します。

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展開⇒標準モジュール追加⇒コードコピペで完了です。動画や一連流れはこちらで確認できます。(別コードをコピーしていますが操作は一緒です)

まとめ

サブフォルダを含めた全フォルダ・ファイルを階層別に出力するコードをお届けしました

ファイルが多くなるほどこの作業は時間を要し、ファイル数が数十個になれば数時間は余裕でかかります。単純作業で本当に時間の浪費なので、コードを使ってサクッと終わらせましょう!

そして、浮いた時間を他の仕事やプライベートに使ってくださいね。

コメント

  1. べーちゃん より:

    こちらのコード、大変助かりました。ありがとうございます!
    f、fLevelのDimがされてなかったので、利用時には自分で追加して実行しました。

  2. hkhk より:

    とても良さそうなツール、コードなのですが、躓いています。

    親フォルダの直下にはファイルが無く、サブフォルダが幾つかあり、それらにはファイルが入っています。
    1つめのサブフォルダ内を抽出後、次のサブフォルダに移る際にエラーが発生します。

    実行時エラー424
    オブジェクトが必要です。

    エラー箇所は
    For Each f In cf.SubFolders

    いろいろググりましたが、よく分からず・・・。
    ご指導、よろしくお願いいたします。

  3. mega より:

    コードありがとうございます。

    VBA初心者なので、いろんなところのコードをいただいて試したんですが、
    なぜかうまく走らず、原因も分からずw

    こちらのコードは分かりやすく整理されていて、一発で使えました。

    自分仕様にアレンジもでき、その際もエラーなし。
    素晴らしいです。

    初心者って、一回エラーが出ると、なにをどうしていいかわからなくなっちゃうんですよね。

    これからもよろしくお願いします。

  4. イーアヤ より:

    めちゃくちゃ助かりました。世の中には天才っているんですね。。。(尊敬しかない)

    コメントされた方がいらっしゃいましたが、
    「Sub GetSubFolder(cf, oRow, oCol)」内で
    Dim f As Folder, fLevel As Longを追加し、
    「Sub lineDraw(oRow, oCol, fLevel) 」内で
    Dim i as longを追加させていただきました。
    (で良いのですかね。。。)

    本当にありがとうございました!