エクセルでファイル一覧を作成 | エクセルでファイル一覧を作成.10(完成) | ExcelマクロVBAでファイル一覧を作成、サブフォルダ以下を全て取得



最終更新日:2014-11-11

エクセルでファイル一覧を作成.10(完成)


エクセルでファイル一覧を作成します。、

サブフォルダ以下も全て取得し、一覧表示します、


いよいよ、最終回です、


使えるマクロにする為の総仕上げになります。


1.画面の更新を停止して、スピードアップする

2.処理中のフォルダをステータスバーに表示する

3.エクセルファイルはクリックで開けるようにする


以上を組み込みます。



では、これらを全て組み込んだ、最終プログラムです。


Option Explicit

Public Const cnsRow As Long = 4 '開始行
Public Const cnsCol As Long = 2 '開始列
Public ColMax As Long     '最終列

Sub ファイル一覧取得()
  Dim objFSO As FileSystemObject
  Dim strDir As String
  Dim i As Long, j As Long
  
  strDir = Cells(cnsRow, cnsCol)
  'FileSystemObjectのインスタンスの生成
  Set objFSO = New FileSystemObject
  'フォルダの存在確認
  If Not objFSO.FolderExists(strDir) Then
    MsgBox ("指定のフォルダは存在しません")
    Exit Sub
  End If
  '画面描画を停止
  Application.ScreenUpdating = False
  '表示領域を初期設定
  Range(Rows(cnsRow), Rows(Cells.SpecialCells(xlCellTypeLastCell).Row)).Clear
  Cells(cnsRow, cnsCol) = strDir
  '開始行列
  i = cnsRow + 1
  j = cnsCol
  ColMax = cnsCol
  '再帰処理モジュールのコール
  Call GetDirFiles(objFSO.GetFolder(strDir), i, j)
  'オブジェクトの解放
  Set objFSO = Nothing
  '列幅を調整
  Range(Columns(cnsCol), Columns(Columns.Count)).ColumnWidth = 3
  Range(Columns(ColMax), Columns(ColMax + 2)).EntireColumn.AutoFit
  'サイズ、更新日時の罫線設定
  Call SetLine2(Range(Cells(cnsRow, ColMax + 1), Cells(i - 1, ColMax + 2)))
  '見出し行の外枠罫線
  Call SetLine3(Range(Cells(cnsRow, cnsCol), Cells(cnsRow, ColMax + 2)))
  '一覧部分の外枠罫線
  Call SetLine3(Range(Cells(cnsRow + 1, cnsCol), Cells(i - 1, ColMax + 2)))
  '見出しの書式設定
  Cells(cnsRow, ColMax).Font.Bold = True
  With Cells(cnsRow, ColMax + 1)
    .Value = "サイズ"
    .HorizontalAlignment = xlRight
  End With
  With Cells(cnsRow, ColMax + 2)
    .Value = "更新日時"
    .HorizontalAlignment = xlRight
  End With
  '指定フォルダに移動しておく
  Cells(cnsRow, cnsCol).Select
  'ステータスバーを消して、描画再開
  Application.StatusBar = False
  Application.ScreenUpdating = True
End Sub

Sub GetDirFiles(ByVal objFolder As Folder, ByRef i As Long, ByRef j As Long)
  Dim objFolderSub As Folder
  Dim objFile As File
  Dim strSplit() As String
  'ステータスバーに処理中のフォルダを表示
  Application.StatusBar = objFolder.Path
  '最終列が増えた場合は、サイズの前に1列追加する
  If j > ColMax Then
    Columns(j).Insert Shift:=xlToRight
    ColMax = j
  End If
  'サブフォルダの取得
  For Each objFolderSub In objFolder.SubFolders
    Cells(i, j) = objFolderSub.Name
    Call SetLine1(i, j)
    i = i + 1
    Call GetDirFiles(objFolderSub, i, j + 1)
  Next
  'ファイルの取得
  For Each objFile In objFolder.Files
    With objFile
      Cells(i, j) = .Name
      strSplit = Split(objFile.Path, ".")
      If UBound(strSplit) > 0 Then
        Select Case LCase(strSplit(UBound(strSplit)))
          Case "xls", "xlsx"
            ActiveSheet.Hyperlinks.Add _
                  Anchor:=Cells(i, j), _
                  Address:=.Path, _
                  TextToDisplay:=.Name
        End Select
      End If
      Cells(i, ColMax + 1) = WorksheetFunction.RoundUp(.Size / 1024, 0)
      Cells(i, ColMax + 1).NumberFormatLocal = "#,##0 ""KB"""
      Cells(i, ColMax + 2) = .DateLastModified
      Cells(i, ColMax + 2).NumberFormatLocal = "yyyy/mm/dd hh:mm:ss"
      Call SetLine1(i, j)
      i = i + 1
    End With
  Next
  'オブジェクトの解放
  Set objFolderSub = Nothing
  Set objFile = Nothing
End Sub

'フォルダ名、ファイル名の行の罫線
Sub SetLine1(ByVal i As Long, ByVal j As Long)
  If j > cnsCol Then
    With Range(Cells(i, cnsCol), Cells(i, j - 1))
      .Borders(xlEdgeLeft).LineStyle = xlContinuous
      .Borders(xlInsideVertical).LineStyle = xlContinuous
    End With
  End If
  With Range(Cells(i, j), Cells(i, ColMax + 2))
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeTop).LineStyle = xlContinuous
  End With
End Sub

'サイズ、更新日時の罫線設定
Sub SetLine2(ByRef myRange As Range)
  With myRange.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlHairline
  End With
  With myRange.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .Weight = xlHairline
  End With
End Sub

'外枠罫線、少し太く
Sub SetLine3(ByRef myRange As Range)
  With myRange.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlMedium
  End With
  With myRange.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlMedium
  End With
  With myRange.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlMedium
  End With
  With myRange.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlMedium
  End With
End Sub


太字が今回追加した部分です。


Application.ScreenUpdating = False
画面の更新を停止します。

実行中は画面が変化しなくなります。

これにより、マクロの処理スピードは飛躍的に高まります。


Application.StatusBar = objFolder.Path
ステータスバーに処理中のフォルダのフルパスを表示します。


strSplit = Split(objFile.Path, ".")
If UBound(strSplit) > 0 Then
  Select Case LCase(strSplit(UBound(strSplit)))
    Case "xls", "xlsx"
      ActiveSheet.Hyperlinks.Add _
            Anchor:=Cells(i, j), _
            Address:=.Path, _
            TextToDisplay:=.Name
  End Select
End If

ファイルの拡張子をとりだして、エクセルなら、ハイパーリンクを挿入しています。

FileSystemObjectのGetExtensionNameで取得出来ますが、

あえて文字列操作で取得しています。

strSplit(文字列, 区切り文字)

は、文字列を区切り文字で分割し、配列にします。

UBound(配列)

は、配列の最大要素数を取得します。

LCase(文字列)

は、英大文字を小文字にします。


なにやら、ずいぶんと面倒な事をしているようでが、

ただしく拡張子を判定するのは、結構面倒なのです。

Splitで、"."で区切れば、2番目が拡張子のようにも思えますが、

拡張子がなかったり、「aaa.bbb.ccc」のように、ファイル名に"."がはいっている場合があります。

また、拡張子は大文字の場合もあります。

ネットで検索して簡単だからと言って使うと、痛い目を見る場合がありますよ。


Select Case

にしているのは、いろいろな拡張子毎に、処理を追加し易いように配慮したものです。


ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, j), Address:=.Path, TextToDisplay:=.Name
ハイパーリンクの挿入です。

設定するセル、リンク先、表示名を指定します。


Application.StatusBar = False
Application.ScreenUpdating = True

ステータスバーをクリアし、画面更新を有効にしています。



シートモジュールも掲載しておきます。


Private Sub btnフォルダ_Click()
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
      Cells(cnsRow, cnsCol) = .SelectedItems(1)
    End If
  End With
End Sub

Private Sub btn実行_Click()
  Call ファイル一覧取得
End Sub



以上で完成です。


ご自分で、使いやすいように改造してみると、プログラムをよく理解できるようになります。



最初は、もう少し初心者向けにするつもりだったのですが、


FileSystemObjectのあたりから、少し難しくなってしまったかもしれません。


最後までお読み頂き、感謝いたします。






同じテーマ「エクセルでファイル一覧を作成」の記事

エクセルでファイル一覧を作成.1(概要)
エクセルでファイル一覧を作成.2(Dir関数1)
エクセルでファイル一覧を作成.3(Dir関数2)
エクセルでファイル一覧を作成.4(FileLen,FileDateTime)
エクセルでファイル一覧を作成.5(FileDialog)
エクセルでファイル一覧を作成.6(FileSystemObject1)
エクセルでファイル一覧を作成.7(FileSystemObject2)

新着記事 ・・・新着記事一覧を見る

最後の空白(や指定文字)以降の文字を取り出す|エクセル関数超技(3月26日)
先頭の数値、最後の数値を取り出す|エクセル関数超技(3月26日)
Excelファイルを開かずにシート名をチェック|ExcelマクロVBAサンプル集(3月23日)
数式の参照しているセルを取得する|ExcelマクロVBAサンプル集(3月18日)
CSVの読み込み方法(改の改)|ExcelマクロVBAサンプル集(3月17日)
変数とプロシージャーの命名について|ExcelマクロVBA技術解説(2月12日)
ファイルの一覧取得・削除(File)|Google Apps Script入門(1月24日)
フォルダの一覧取得・作成・削除(Folder)|Google Apps Script入門(1月24日)
フォルダとファイルを扱う(DriveApp)|Google Apps Script入門(1月24日)
スプレッドシートが非常に遅い、高速化するには|Google Apps Script入門(1月17日)

アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|ExcelマクロVBA入門
2.RangeとCellsの使い方|ExcelマクロVBA入門
3.徹底解説(VLOOKUP,MATCH,INDEX,OFFSET)|エクセル関数超技
4.Range以外の指定方法(Cells,Rows,Columns)|ExcelマクロVBA入門
5.セルの参照範囲を可変にする(OFFSET,COUNTA,MATCH)|エクセル関数超技
6.セルのコピー&値の貼り付け(PasteSpecial)|ExcelマクロVBA入門
7.変数とデータ型(Dim)|ExcelマクロVBA入門
8.ひらがな⇔カタカナの変換|エクセル基本操作
9.CSVの読み込み方法|ExcelマクロVBAサンプル集
10.VBAのFindメソッドの使い方には注意が必要です|ExcelマクロVBA技術解説



  • >
  • >
  • >
  • エクセルでファイル一覧を作成.10(完成)

  • このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


    記述には細心の注意をしたつもりですが、
    間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
    なお、掲載のVBAコードは自己責任で使ってください。万一データ破損等の損害が発生しても責任は負いません。

    ↑ PAGE TOP