Excel VBA ファイル名一覧を簡易作成するマクロ

今回は、Excel VBAで、ファイル名と更新日時をまとめた一覧を作成するマクロを書く。

サクッと実行したくて作ってるので、個人用マクロブックに組み込むと良いだろう。

個人用マクロブックとかについては、ここを展開。

オリジナルのマクロをリボンに追加する方法はこちら。

個人用マクロブックについては、こちらやこちらで述べています。

動作イメージなど

今回のマクロを実行すると、フォルダを選択するダイアログが出てくるので、ファイル名を一覧出力したいフォルダを選択する。

そのフォルダ内のファイル名・更新日時の一覧が、新規のExcelブックに出力される。

B列のファイル名にはハイパーリンクを入れてあるので、クリックすれば当該ファイルが開かれる。

Excel VBA フォルダを複数一括新規作成する手抜きマクロ個人用マクロブックに組み込めるよ

2022年4月6日

ソースコード

今回のマクロでは、VBAのFileSystemObjectを使う。

そのため事前に、ExcelのVBEで「ツール」→「参照設定」から「Microsoft Scripting Runtime」を有効にしておこう。

Excel VBA FileSystemObject(1)変数宣言など

2020年5月4日

それでは下記にソースコードを書くので、このマクロ「makeFileList」を実行すれば良い。

Sub makeFileList()
'ファイル一覧を作成する
    Dim myPath      As String
    
    'フォルダを選択させる
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not .Show Then Exit Sub
        myPath = .SelectedItems(1) '選択したフォルダ
    End With
    
    
    Dim FSO         As New FileSystemObject
    Dim myFiles     As Object
    Dim cnt         As Long
    
    Dim eachFile    As File
    Set myFiles = FSO.GetFolder(myPath).Files
    cnt = myFiles.Count
    
    If cnt = 0 Then Exit Sub
    
    Application.ScreenUpdating = False '描画省略
    
    Dim fileArr     As Variant
    Const colSize   As Long = 3
    ReDim fileArr(1 To cnt, 1 To colSize)
    
    Dim i           As Long
    
    'ファイル名の情報を配列に入れていく
    For Each eachFile In myFiles
        i = i + 1
        fileArr(i, 1) = i '№
        fileArr(i, 2) = eachFile.Name 'ファイル名
        fileArr(i, 3) = eachFile.DateLastModified '更新日時
    
    Next eachFile
    
    Workbooks.Add
    
    Dim ws      As Worksheet: Set ws = ActiveSheet
    
    With ws
        '見出しを付ける
        .Cells(1, 1).Value = "№"
        .Cells(1, 2).Value = "ファイル名"
        .Cells(1, 3).Value = "更新日時"
    
        .Rows(1).HorizontalAlignment = xlCenter  '左右中央揃え
        .Rows(1).AutoFilter 'オートフィルタをかける
    
    
        .Cells(2, 1).Resize(cnt, colSize).Value = fileArr 'ファイル名の配列をセット
        .Cells(1, 1).Resize(1, colSize).EntireColumn.AutoFit '列幅自動調整
    
        'ファイル名にハイパーリンクを付加
        For i = 1 To cnt
            .Hyperlinks.Add Anchor:=.Cells(i + 1, 2), Address:=myPath ＆ "\" ＆ fileArr(i, 2)
        Next i
        
        .Rows(2).Select
        ActiveWindow.FreezePanes = True 'ウインドウ枠固定
        .Cells(2, 2).Select
    End With

    Application.ScreenUpdating = True '描画再開

End Sub