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

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