【Excel VBA】指定したフォルダにあるファイル一覧を出力するマクロ

「あるフォルダの下にあるファイルをExcelに出力したい」という要望に応えて、指定したフォルダの下にあるファイル、さらにはサブフォルダにあるファイルも一覧として出力するマクロを作成しました。

今回のマクロのイメージはこんな感じ↓です！

今回作成するにあたって、こちらのサイトを参考にしました。特に再帰呼び出しを使って、サブフォルダのファイル一覧を出力するところは自分では思いつかなかったので、とても助かりました。

参考 VBA サブフォルダ含むファイル一覧を再帰的に取得する株式会社医療情報総合研究所

指定したフォルダにあるファイル一覧を出力するマクロ

指定したフォルダにあるファイル一覧を出力するマクロ

今回のマクロでは、ファイル情報を取得するためにFile System Objectを使用するので、まずはその設定から始めます。

1. File System Objectを使うための準備(参照設定)

画面上部の[ツール] / [参照設定]をクリックします。

参照設定画面にて、Microsoft Scripting Runtime にチェックを付けて、[OK]ボタンをクリックします。

準備はこれで完了です！

2. VBAのソースコードを書く

ソースコードを書いていきましょう。処理内容はソースのコメントに書いてあります。

コピペするときのポイント

SEARCH_PATHは、自分のPCで出力したいフォルダパスに修正してください！

たけのこ

右上の”copy”をクリックしたらソースをコピーできますよ！

copy

' 参考URL http://blog.jmiri.net/?p=1763

Private Const SEARCH_PATH As String = "C:\Users\Public\Documents\ファイル一覧"
Private fileCount As Long

' フォルダにあるファイル一覧を作成する
Public Sub MakeFileList()

    Dim startCell As Range
    Dim maxRow As Long
    Dim maxCol As Long
    fileCount = 0
    
    ' 一覧のヘッダーを設定
    Cells(1, 1).Value = "フォルダパス"
    Cells(1, 2).Value = "ファイル名"

    ' 一覧を出力し始めるセルを設定
    Set startCell = Cells(2, 1)
    startCell.Select
    
    'シートをいったんクリア
    maxRow = startCell.SpecialCells(xlLastCell).Row
    maxCol = startCell.SpecialCells(xlLastCell).Column
    Range(startCell, Cells(maxRow, maxCol)).ClearContents
    
    ' 画面更新をストップ
    Application.ScreenUpdating = False
    
    Call SetFolderPathAndFileName(SEARCH_PATH)
    
    startCell.Select
    
    ' 画面更新を元に戻す
    Application.ScreenUpdating = True
    
    MsgBox "ファイル一覧の出力が完了しました" & vbCrLf & "全ファイル数:" & fileCount
    
End Sub

' ファイル取得メソッド
Sub SetFolderPathAndFileName(ByVal searchPath As String)

    Dim FSO As New FileSystemObject
    Dim objFiles As File
    Dim objFolders As Folder

    ' ルートフォルダのパスを出力する
    ActiveCell.Value = searchPath
    
    'フォルダにあるファイルを出力する
    For Each objFiles In FSO.GetFolder(searchPath).Files
    
        fileCount = fileCount + 1
                
        ActiveCell.Offset(0, 1).Value = objFiles.Name
        
        ' セルを1つ下に移動する
        ActiveCell.Offset(1, 0).Select
        
    Next
    
    ' フォルダにファイルが1つもない場合に、セルを1つ下に移動する
    If FSO.GetFolder(searchPath).Files.Count = 0 Then
    
        ActiveCell.Offset(1, 0).Select
    
    End If
    
    'サブフォルダが存在する場合には、再帰呼び出しをする
    For Each objFolders In FSO.GetFolder(searchPath).SubFolders
        
        Call SetFolderPathAndFileName(objFolders.Path)
        
    Next
    
End Sub