エクセルでファイル一覧を作成.№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入門
- ホーム
- マクロVBA応用編
- マクロVBAサンプル集
- ファイル一覧を作成
- エクセルでファイル一覧を作成.№10(完成)
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。