VBAサンプル集
エクセルでファイル一覧を作成.№10(完成)

ExcelマクロVBAでファイル一覧を作成、サブフォルダ以下を全て取得
公開日:2013年5月以前 最終更新日:2017-03-27

エクセルでファイル一覧を作成.№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
    'フォルダにハイパーリンクを設定する場合
    'ActiveSheet.Hyperlinks.Add _
    '      Anchor:=Cells(i, j), _
    '      Address:=objFolderSub.Path, _
    '      TextToDisplay:=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のあたりから、少し難しくなってしまったかもしれません。


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


※後日追記
フォルダにもハイパーリンクを設定する場合のコードを追記しました。
'フォルダにハイパーリンクを設定する場合
VBAコードの中の、このコメント部分になります。




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

エクセルでファイル一覧を作成.№1(概要)
エクセルでファイル一覧を作成.№2(Dir関数1)
エクセルでファイル一覧を作成.№3(Dir関数2)
エクセルでファイル一覧を作成.№4(FileLen,FileDateTime)
エクセルでファイル一覧を作成.№5(FileDialog)
エクセルでファイル一覧を作成.№6(FileSystemObject1)
エクセルでファイル一覧を作成.№7(FileSystemObject2)
エクセルでファイル一覧を作成.№8(インデント)
エクセルでファイル一覧を作成.№9(罫線)
エクセルでファイル一覧を作成.№10(完成)


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

TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(Boolean)のis変数・フラグについて|VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する|VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.セルのクリア(Clear,ClearContents)|VBA入門
8.メッセージボックス(MsgBox関数)|VBA入門
9.条件分岐(Select Case)|VBA入門
10.マクロとは?VBAとは?VBAでできること|VBA入門




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


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


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