ファイル名一覧マクロ

 このマクロでは、入力プロンプトで指定したフォルダの中にあるファイルのセルの値を、サブフォルダの中も含めて、ExcelのSheet1に書き出すマクロです。ファイル集計をする時などに便利です。
 構成は、まず、mainプロシージャでフォルダ名を入力し、Sheet1をクリアして以前のデータを消去してから、タイトル行を書き出します。その後、WriteFileListプロシージャを呼び出し、フォルダ内のファイル名等を書き出します。もし当該フォルダにサブフォルダがある場合には、そのサブフォルダ内のファイルに対しても同様の処理を行います。
 以下の2つのプロシージャをExcelの標準モジュールにコピー&ペーストすれば、そのまま使用できます。

' フォルダ名の入力、タイトル行の書き出しを行うメインプロシージャ
Sub main()

   ' ワークシートの定義
   Dim dstSheet As Worksheet
   Set dstSheet = ThisWorkbook.Worksheets("集計表")

   ' 対象フォルダの入力
   Dim dlg As FileDialog
   Dim sFolder As String

   Set dlg = Application.FileDialog(msoFileDialogFolderPicker)

   ' キャンセルボタンクリック時にマクロを終了
   If dlg.Show = False Then Exit Sub

   ' フォルダーのフルパスを変数に格納
   sFolder = dlg.SelectedItems(1)

   ' 画面更新OFF
   Application.ScreenUpdating = False

   ' シートのクリア
   ThisWorkbook.Sheets("Sheet1").UsedRange.Delete

   ' タイトル行の書き出し
   dstSheet.Cells(1, 1) = "ファイル名"
   dstSheet.Cells(1, 2) = "フォルダ名"
   ' タイトル行の書き出し(集計対象部分)
   dstSheet.Cells(1, 3) = "2019年上期"
   dstSheet.Cells(1, 4) = "2019年下期"
   dstSheet.Cells(1, 5) = "2020年上期"
   dstSheet.Cells(1, 6) = "2020年下期"
   dstSheet.Cells(1, 7) = "2021年上期"
   dstSheet.Cells(1, 8) = "2021年下期"
   dstSheet.Cells(1, 9) = "2022年上期"
   dstSheet.Cells(1, 10) = "2022年下期"
   dstSheet.Cells(1, 11) = "2023年上期"
   dstSheet.Cells(1, 12) = "2023年下期"

   ' タイトル行の属性
   dstSheet.Range(Cells(1, 1), Cells(1, 2)).Interior.Color = RGB(153, 255, 255)
   dstSheet.Range(Cells(1, 3), Cells(1, 12)).Interior.Color = RGB(0, 255, 0)
   dstSheet.Range(Cells(1, 1), Cells(1, 12)).Font.Color = RGB(0, 0, 0)
   dstSheet.Range(Cells(1, 1), Cells(1, 12)).HorizontalAlignment = xlCenter

   ' 書き出し位置設定
   i = 2

   ' サブプロシージャの呼び出し
   WriteFileList sFolder, i

   ' 画面更新ON
   Application.ScreenUpdating = True

End Sub

' ファイル名を書き出すサブプロシージャ
Sub WriteFileList(sFolder, i)

   ' 集計用Excelの定義
   Dim dstSheet As Worksheet
   Set dstSheet = ThisWorkbook.Worksheets("集計表")

   ' オブジェクト型変数の代入
   Set objFileSystem = CreateObject("Scripting.FileSystemObject")
   Set objFolder = objFileSystem.GetFolder(sFolder)
   Set objSubFolders = objFolder.SubFolders
   Set objFiles = objFolder.Files

   ' フォルダ内のファイル処理
   For Each File In objFiles

      ' 集計対象Excelを開く
      Dim srcBook As Workbook
      Set srcBook = Workbooks.Open(File.Path)
      Dim srcSheet As Worksheet
      Set srcSheet = srcBook.Worksheets(1)

      ' ファイル名の書き出し
      dstSheet.Cells(i, 1) = File.Name

      ' フォルダ名の書き出し
      dstSheet.Cells(i, 2) = File.ParentFolder.Path

      ' 集計対象の書き出し
      For j = 0 To 9        dstSheet.Cells(i, 3 + j).Value = srcSheet.Cells(31, 6 + j)
      Next j

      ' 集計対象Excelを閉じる
      srcBook.Close False

      i = i + 1
   Next

   ' サブフォルダが存在する場合には同様の処理を繰り返す
   For Each SubFolder In objSubFolders
      WriteFileList SubFolder.Path, i
   Next

End Sub
ホーム
inserted by FC2 system