編集

【ExcelVBA】フォルダ選択ダイアログ、ファイル一覧出力、セルの書式設定、etc.

｜2024/06/20

今回は、選択したフォルダからファイル一覧を取得するコードをご紹介します。なお、ファイル一覧の処理だけでなく、フォルダの存在確認、新しいシートの挿入方法、日付とFormat関数、セルの書式設定についても学ぶことができます。

業務側の要望として、変更した箇所の文字や背景に色を付けたいとか結構あるので、これを機会に覚えてしまいましょう。

以前、ユーザーがその都度ファイルを選べるように、ファイル選択ダイアログを表示する処理をご紹介しましたが、今回はフォルダ選択ダイアログを表示させるコードもご紹介します。ファイルの選択ダイアログについては下記の記事をご参照ください。

今回は、ソースコードの行数は多いですが、決して難しい処理はしていません。フォルダ構成および画面設計の環境を整え、作成してみてください。

フォルダ構成

先に業務環境の把握から。年フォルダの中に毎月の集計表が格納されています。この集計表が何月分まで格納されているか一覧を出力したい...という処理をします。

このテストデータだとデータ量が少ないため、マクロを組むにも至らず手作業でも直ぐにできそうではあるのですが...こういった年月日で綺麗に管理させていれば本来手間がかかることはないのですけども。取り敢えずで適当に格納していると...笑

ファイル一覧を出力する機会というのは無さそうに見えて、極々たまにあります笑　監査対象で慌てて整理するなんてこともありますしねぇｗ

画面設計

ファイル選択ダイアログを表示させる処理とほぼ同じですが、画像に記載してある通り、実行結果後のパスのお尻に「￥」（円マーク）は付与されません。それだけ覚えておいてください。

  • シート名：入力画面
  • セルC2：フォルダパスとして名前付け
  • 参照ボタン：フォルダ選択 マクロの登録
  • ファイル一覧出力：ファイル一覧の作成 マクロの登録

処理実行結果

「ファイル一覧出力」ボタンを押すことで、同じExcelブック内の新規シートにファイル一覧を書き出します。

フォルダ選択ダイアログ - ソースコード（ExcelVBA） 

Option Explicit
Private ObjWSH As WshShell

Sub フォルダ選択()

    Set ObjWSH = New WshShell
    
    Dim SetFolder As String
    SetFolder = ObjWSH.SpecialFolders("Desktop")
    ChDrive Drive:="C"
    ChDir Path:=SetFolder

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = SetFolder
        If .Show = True Then
            ThisWorkbook.Worksheets("入力画面").Range("フォルダパス") = .SelectedItems(1)
        Else
            MsgBox "キャンセルしました。"
        End If
    End With

End Sub

フォルダ選択ダイアログ - ポイント

  1. 実行にはツールの参照設定から「Windows Script Host Object Model」にチェックを入れてください。
  2. SpecialFolders（”Desktop”）でデスクトップのパスを取得し、ChDir Pathでデスクトップを初期位置としています。
  3. ファイル選択ダイアログの処理の時とは違い、今回は「Application.FileDialog」を使用しています。

ファイル一覧出力 - ソースコード（ExcelVBA）

Option Explicit
Private ObjFSO As FileSystemObject

Sub ファイル一覧の作成()

    Set ObjFSO = New FileSystemObject
    
    Dim WS As Worksheet
    Dim FolderPath As String
    Set WS = Worksheets("入力画面")
    FolderPath = WS.Range("フォルダパス")
    
    If ObjFSO.FolderExists(FolderPath) = False Then
        MsgBox "フォルダが存在しません。"
        End
    End If
    
    Dim NewWS As Worksheet
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Format(Now, "yyyyMMdd_hhmmss")
    Set NewWS = ActiveSheet
    
    With NewWS
        .Cells.Font.Name = "Meiryo UI"
        .Cells(1, 1) = "ファイル名一覧"
        .Cells(1, 1).Font.Bold = True
        .Cells(1, 1).Font.Size = 16
        .Cells(2, 1) = "ファイル名"
        .Cells(2, 1).Font.ColorIndex = 56
        .Cells(2, 1).Interior.ColorIndex = 15
        Columns("A").ColumnWidth = 30
        .Cells(2, 2) = "更新日時"
        .Cells(2, 2).Font.ColorIndex = 56
        .Cells(2, 2).Interior.ColorIndex = 15
        Columns("B").ColumnWidth = 20
    End With
    
    Dim YearFolder As Folder
    Dim FilesCollection As Files
    Dim CurrentFile As File
    Dim i As Long: i = 3
    
    Set YearFolder = ObjFSO.GetFolder(FolderPath)
    Set FilesCollection = YearFolder.Files
    For Each CurrentFile In FilesCollection
        NewWS.Cells(i, 1).Value = CurrentFile.Name
        NewWS.Cells(i, 2).Value = CurrentFile.DateLastModified
        i = i + 1
    Next

    ThisWorkbook.Save

End Sub

ファイル一覧出力 - ポイント

  1. 実行にはツールの参照設定から「Microsoft Scripting Runtime」にチェックを入れてください。
  2. フォルダの存在確認として、フォルダパスに入力したフォルダが見当たらなった場合、メッセージを表示して何もせずに処理を終了させています。
  3. 新規ワークシートを挿入する際、常に一番右側に挿入するようにしています。
  4. シート名は日時にしています。Excelの仕様として、同じ名前のシート名を作成することはできません。Now関数で現在日時を取得し、Format関数で表示書式を変換しています。