突然ですが本業でマクロを使ったファイルリスト作成機を作りました!
この時は動けばOK程度の荒めの仕様だったのですが、せっかくなので汎用的に使えるようにもうちょっとカスタマイズしたので説明付きでこのサイトに保管します
こうやって残しておけば次必要な時にダウンロードするだけの半分自分向けですが良かったら使ってください
ツールの仕様
VBAのことはいいからツールを使ってみたい!って方向けにまずはツールの仕様から
設定項目
絵が合った方が早いのでまずはエクセルの切り抜きから
![](https://javeo.jp/wp-content/uploads/2024/07/2024-07-10_22h57_23.png)
対象フォルダ指定(グレー背景箇所)
まずは取得対象とするフォルダの指定
サブフォルダも取得するようにすると対象フォルダ以下全てのフォルダが取得対象に
ちなみにフォルダ名のところでダブルクリックするとダイアログで対象フォルダを選べる仕様にしています
フォルダ名の指定(青背景箇所)
次はフォルダ名の指定
各項目の入力条件で取得対象を制限できます
フォルダ名検索 | 検索したい名前を指定※パイプ文字で区切って複数指定可 |
---|---|
一致パターン | “部分一致”、”完全一致”、”前方一致”、”後方一致”の中から選ぶ |
指定 or 除外 | “フォルダ名検索”,”一致パターン”に該当した時に対象とするか対象外にするか |
ファイル名の指定(緑背景箇所)
ファイル名の指定もフォルダと同じ方法
このファイル名に拡張子は含まないので注意
拡張子の指定(オレンジ背景箇所)
フォルダ名、ファイル名の指定と同じ
.(ドット)はいらないのでエクセルなら”xlsx”でOK
プログラムについて
ここからVBAの説明に移ります
コピペでそのまま使えるプログラムと各プロシージャの説明を
必要な参照設定
フォルダ・ファイルの情報を扱うので必須レベルな”FileSystemObject“を使用しますから”Microsoft Scripting Runtime“の参照をどうぞ
その他はありませんので魔改造する時に必要に応じて
![](https://javeo.jp/wp-content/uploads/2024/07/2024-07-07_23h49_05.png)
コピペ用 プログラムの全貌
説明なんぞ不要でファイルがあればいい、プログラムがあればいいって方向けに最初にVBAの全プログラムとそのまま使えるマクロファイルです
長ったらしいので畳んでますが見たい方は広げてください
Option Explicit
Enum lngCol
file_name = 1
ext_name
file_size
create_date
mod_date
file_path
file_path_split
End Enum
Dim objFso As New Scripting.FileSystemObject
Sub GetFileList()
Dim ws As Worksheet
Dim target_folder As String
'---起点フォルダの確認
target_folder = Trim(Range("TARGET_FOLDER").Value)
If objFso.FolderExists(target_folder) = False Then
MsgBox "対象フォルダが見つかりません", vbCritical
Exit Sub
End If
'---フォルダ名の一致判定
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
If Len(Trim(Range("FOLDER_MATCH_TYPE").Value)) = 0 Then
MsgBox "フォルダ名の一致タイプ を入力してください", vbCritical
Exit Sub
End If
If Len(Trim(Range("FOLDER_MATCH_PATTERN").Value)) = 0 Then
MsgBox "フォルダ名の一致パターン を入力してください", vbCritical
Exit Sub
End If
Else
Range("FOLDER_NAME").Value = Trim(Range("FOLDER_NAME").Value)
End If
'---ファイル名の一致判定
If Len(Trim(Range("FILE_NAME").Value)) > 0 Then
If Len(Trim(Range("FILE_MATCH_TYPE").Value)) = 0 Then
MsgBox "フォルダ名の一致タイプ を入力してください", vbCritical
Exit Sub
End If
If Len(Trim(Range("FILE_MATCH_PATTERN").Value)) = 0 Then
MsgBox "フォルダ名の一致パターン を入力してください", vbCritical
Exit Sub
End If
End If
'---拡張子の一致判定
If Len(Trim(Range("EXT_NAME").Value)) > 0 Then
If Len(Trim(Range("EXT_MATCH_TYPE").Value)) = 0 Then
MsgBox "拡張子の一致タイプ を入力してください", vbCritical
Exit Sub
End If
If Len(Trim(Range("EXT_MATCH_PATTERN").Value)) = 0 Then
MsgBox "拡張子の一致パターン を入力してください", vbCritical
Exit Sub
End If
End If
Set ws = Sheet2
'---テーブルをリセットする
With ws
.Select
'---テーブルが空だとエラーになるのでエラーを無視するようにする
On Error Resume Next
.Range(Range("FILE_TABLE").Address).EntireRow.Delete
On Error GoTo 0
End With
'---まず指定フォルダのファイルを収集する
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
'---指定の場合一致したらファイル情報を取得する
If Range("FOLDER_MATCH_PATTERN").Value = "指定" Then
If in_array(objFso.GetFolder(target_folder).Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = True Then
Call GetFileData(ws, Range("FOLDER_NAME").Value)
End If
End If
'---除外の場合は不一致ならファイル情報取得して再帰処理する
If Range("FOLDER_MATCH_PATTERN").Value = "除外" Then
If in_array(objFso.GetFolder(target_folder).Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = False Then
Call GetFileData(ws, Range("FOLDER_NAME").Value)
End If
End If
Else
Call GetFileData(ws, Range("TARGET_FOLDER").Value)
End If
'-サブフォルダを対象とするか
If Range("TARGET_SUBFOLDER").Value = "する" Then
Call GetSubFoler(ws, target_folder)
End If
Set ws = Nothing
Application.StatusBar = False
'---先頭行が空白だったら(絶対空白のはず)削除する
If Len(Trim(Range("FILE_TABLE").Item(1).Value)) = 0 Then
On Error Resume Next
Range("FILE_TABLE").ListObject.ListRows(1).Delete
On Error GoTo 0
End If
Range("FILE_TABLE").Item(1).Select
MsgBox "終了しました"
End Sub
Sub DeleteFileList()
Dim ws As Worksheet
Set ws = Sheet2
'---テーブルをリセットする
With ws
.Select
On Error Resume Next
.Range(Range("FILE_TABLE").Address).EntireRow.Delete
On Error GoTo 0
End With
Set ws = Nothing
Range("FILE_TABLE").Item(1).Select
MsgBox "終了しました"
End Sub
Private Function GetFileData(ws As Worksheet, target_folder As String)
'======================================================================
' 指定フォルダの中にあるファイル情報を取得してリストに反映する
'======================================================================
Dim lngRow As Long
Dim file_path As String
Dim objFile As Scripting.File
Dim get_file_bool As Boolean
Application.StatusBar = target_folder & " のファイル情報を取得中・・・"
For Each objFile In objFso.GetFolder(target_folder).Files
'---ファイルの取得判定の初期値を設定(True)
get_file_bool = True
'---ファイル名検索に指定があったら
If Len(Trim(Range("FILE_NAME").Value)) > 0 Then
'---ファイル名(拡張子除く)が条件と一致しているか確認
If in_array(objFso.GetBaseName(objFile.Name), Split(Range("FILE_NAME").Value, "|"), Range("FILE_MATCH_TYPE").Value) = IIf(Range("FILE_MATCH_PATTERN").Value = "指定", True, False) Then
get_file_bool = True
Else
get_file_bool = False
GoTo continue
End If
End If
'---拡張子に指定があったら
If Len(Trim(Range("EXT_NAME").Value)) > 0 Then
If in_array(objFso.GetExtensionName(objFile.Name), Split(Range("EXT_NAME").Value, "|"), Range("EXT_MATCH_TYPE").Value) = IIf(Range("EXT_MATCH_PATTERN").Value = "指定", True, False) Then
get_file_bool = True
Else
get_file_bool = False
GoTo continue
End If
End If
'---取得対象と判定されたら情報を取得して書き出す
If get_file_bool = True Then
With ws
.Select
'---テーブルに行を追加する
Range("FILE_TABLE").ListObject.ListRows.Add AlwaysInsert:=False
lngRow = Range("FILE_TABLE").Item(Range("FILE_TABLE").Cells.Count).Row
.Cells(lngRow, lngCol.file_name).Value = objFile.Name
.Cells(lngRow, lngCol.ext_name).Value = objFso.GetExtensionName(objFile.Path)
.Cells(lngRow, lngCol.file_size).Value = objFile.Size
.Cells(lngRow, lngCol.create_date).Value = objFile.DateCreated
.Cells(lngRow, lngCol.mod_date).Value = objFile.DateLastModified
file_path = Replace(objFile.Path, "\" & objFile.Name, "")
.Cells(lngRow, lngCol.file_path).Value = Replace(objFile.Path, "\" & objFile.Name, "")
.Cells(lngRow, lngCol.file_path_split).Resize(, UBound(Split(file_path, "\")) + 1) = Split(file_path, "\")
End With
End If
continue:
Next
End Function
Private Function GetSubFoler(ws As Worksheet, target_folder As String)
'======================================================================
' 再帰処理でフォルダを潜りながらそのフォルダのファイルを取得する
'======================================================================
Dim objFld As Scripting.Folder
For Each objFld In objFso.GetFolder(target_folder).SubFolders
'---フォルダ名検索に指定があったら
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
'---指定の場合一致したらファイル情報を取得する
If Range("FOLDER_MATCH_PATTERN").Value = "指定" Then
If in_array(objFld.Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = True Then
Call GetFileData(ws, objFld.Path)
End If
'---どちらにしても再帰処理はかける
Call GetSubFoler(ws, objFld.Path)
End If
'---除外の場合は不一致ならファイル情報取得して再帰処理する
If Range("FOLDER_MATCH_PATTERN").Value = "除外" Then
If in_array(objFld.Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = False Then
Call GetFileData(ws, objFld.Path)
Call GetSubFoler(ws, objFld.Path)
End If
End If
Else
Call GetFileData(ws, objFld.Path)
Call GetSubFoler(ws, objFld.Path)
End If
Next
End Function
Private Function in_array(target_str As String, target_array As Variant, Optional match_type As String = "完全一致") As Boolean
'======================================================================
' パターンに合わせて一致判定を返す
'======================================================================
Dim arr As Variant
For Each arr In target_array
Select Case match_type
Case "完全一致"
If LCase(target_str) = LCase(arr) Then
in_array = True
Exit Function
End If
Case "部分一致"
If LCase(target_str) Like "*" & LCase(arr) & "*" Then
in_array = True
Exit Function
End If
Case "前方一致"
If LCase(target_str) Like LCase(arr) & "*" Then
in_array = True
Exit Function
End If
Case "後方一致"
If LCase(target_str) Like "*" & LCase(arr) Then
in_array = True
Exit Function
End If
Case Else
End Select
Next
in_array = False
End Function
ここからはプログラムをプロシージャ別に解説していきます
共通変数
Option Explicit
Enum lngCol
file_name = 1
ext_name
file_size
create_date
mod_date
file_path
End Enum
Dim objFso As New Scripting.FileSystemObject
個人的な話ですが、昔はプロシージャ―の外に書く共通変数にしたがっていた時期がありましたが最近はなるべく共通変数は減らして値格納する変数はNGにしています
Enum(列挙型)はExcelならではですが、列番号を宣言してあげると後から項目追加・削除したり編集する可能性があるなら便利ですよね
GetFileList(メインプロシージャ―)
Sub GetFileList()
Dim ws As Worksheet
Dim target_folder As String
'---起点フォルダの確認
target_folder = Trim(Range("TARGET_FOLDER").Value)
If objFso.FolderExists(target_folder) = False Then
MsgBox "対象フォルダが見つかりません", vbCritical
Exit Sub
End If
'---フォルダ名の一致判定
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
If Len(Trim(Range("FOLDER_MATCH_TYPE").Value)) = 0 Then
MsgBox "フォルダ名の一致タイプ を入力してください", vbCritical
Exit Sub
End If
If Len(Trim(Range("FOLDER_MATCH_PATTERN").Value)) = 0 Then
MsgBox "フォルダ名の一致パターン を入力してください", vbCritical
Exit Sub
End If
Else
Range("FOLDER_NAME").Value = Trim(Range("FOLDER_NAME").Value)
End If
'---ファイル名の一致判定
If Len(Trim(Range("FILE_NAME").Value)) > 0 Then
If Len(Trim(Range("FILE_MATCH_TYPE").Value)) = 0 Then
MsgBox "フォルダ名の一致タイプ を入力してください", vbCritical
Exit Sub
End If
If Len(Trim(Range("FILE_MATCH_PATTERN").Value)) = 0 Then
MsgBox "フォルダ名の一致パターン を入力してください", vbCritical
Exit Sub
End If
End If
'---拡張子の一致判定
If Len(Trim(Range("EXT_NAME").Value)) > 0 Then
If Len(Trim(Range("EXT_MATCH_TYPE").Value)) = 0 Then
MsgBox "拡張子の一致タイプ を入力してください", vbCritical
Exit Sub
End If
If Len(Trim(Range("EXT_MATCH_PATTERN").Value)) = 0 Then
MsgBox "拡張子の一致パターン を入力してください", vbCritical
Exit Sub
End If
End If
Set ws = Sheet2
'---テーブルをリセットする
With ws
.Select
'---テーブルが空だとエラーになるのでエラーを無視するようにする
On Error Resume Next
.Range(Range("FILE_TABLE").Address).EntireRow.Delete
On Error GoTo 0
End With
'---まず指定フォルダのファイルを収集する
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
'---指定の場合一致したらファイル情報を取得する
If Range("FOLDER_MATCH_PATTERN").Value = "指定" Then
If in_array(objFso.GetFolder(target_folder).Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = True Then
Call GetFileData(ws, Range("FOLDER_NAME").Value)
End If
End If
'---除外の場合は不一致ならファイル情報取得して再帰処理する
If Range("FOLDER_MATCH_PATTERN").Value = "除外" Then
If in_array(objFso.GetFolder(target_folder).Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = False Then
Call GetFileData(ws, Range("FOLDER_NAME").Value)
End If
End If
Else
Call GetFileData(ws, Range("TARGET_FOLDER").Value)
End If
'-サブフォルダを対象とするか
If Range("TARGET_SUBFOLDER").Value = "する" Then
Call GetSubFoler(ws, target_folder)
End If
Set ws = Nothing
Application.StatusBar = False
'---先頭行が空白だったら(絶対空白のはず)削除する
If Len(Trim(Range("FILE_TABLE").Item(1).Value)) = 0 Then
On Error Resume Next
Range("FILE_TABLE").ListObject.ListRows(1).Delete
On Error GoTo 0
End If
Range("FILE_TABLE").Item(1).Select
MsgBox "終了しました"
End Sub
長いように見えてやっていることは
- エクセルで入力した内容(条件)をチェックする
- 出力先のシート(厳密にはテーブル)をリセットする
- 指定したフォルダのファイル情報を取得する
だけです
当たり前ですがエクセルで設定できる項目に比例してソースが長くなってしまうのはやむなし
GetFileData
Private Function GetFileData(ws As Worksheet, target_folder As String)
'======================================================================
' 指定フォルダの中にあるファイル情報を取得してリストに反映する
'======================================================================
Dim lngRow As Long
Dim file_path As String
Dim objFile As Scripting.File
Dim get_file_bool As Boolean
Application.StatusBar = target_folder & " のファイル情報を取得中・・・"
For Each objFile In objFso.GetFolder(target_folder).Files
'---ファイルの取得判定の初期値を設定(True)
get_file_bool = True
'---ファイル名検索に指定があったら
If Len(Trim(Range("FILE_NAME").Value)) > 0 Then
'---ファイル名(拡張子除く)が条件と一致しているか確認
If in_array(objFso.GetBaseName(objFile.Name), Split(Range("FILE_NAME").Value, "|"), Range("FILE_MATCH_TYPE").Value) = IIf(Range("FILE_MATCH_PATTERN").Value = "指定", True, False) Then
get_file_bool = True
Else
get_file_bool = False
GoTo continue
End If
End If
'---拡張子に指定があったら
If Len(Trim(Range("EXT_NAME").Value)) > 0 Then
If in_array(objFso.GetExtensionName(objFile.Name), Split(Range("EXT_NAME").Value, "|"), Range("EXT_MATCH_TYPE").Value) = IIf(Range("EXT_MATCH_PATTERN").Value = "指定", True, False) Then
get_file_bool = True
Else
get_file_bool = False
GoTo continue
End If
End If
'---取得対象と判定されたら情報を取得して書き出す
If get_file_bool = True Then
With ws
.Select
'---テーブルに行を追加する
Range("FILE_TABLE").ListObject.ListRows.Add AlwaysInsert:=False
lngRow = Range("FILE_TABLE").Item(Range("FILE_TABLE").Cells.Count).Row
.Cells(lngRow, lngCol.file_name).Value = objFile.Name
.Cells(lngRow, lngCol.ext_name).Value = objFso.GetExtensionName(objFile.Path)
.Cells(lngRow, lngCol.file_size).Value = objFile.Size
.Cells(lngRow, lngCol.create_date).Value = objFile.DateCreated
.Cells(lngRow, lngCol.mod_date).Value = objFile.DateLastModified
file_path = Replace(objFile.Path, "\" & objFile.Name, "")
.Cells(lngRow, lngCol.file_path).Value = Replace(objFile.Path, "\" & objFile.Name, "")
.Cells(lngRow, lngCol.file_path_split).Resize(, UBound(Split(file_path, "\")) + 1) = Split(file_path, "\")
End With
End If
continue:
Next
End Function
まず今回のようなループが多いプログラムはステータスバーに進捗状況を表示してあげると親切
他の言語に慣れるとVBAのForループにcontinueが無いのが地味にストレスなんでGoToで無理矢理再現したことと、PHPで出会ったin_arrayは後述していますがVBAにない関数は自作してしまえってことでこちらも再現しただけの関数を準備しました
他には出力先をテーブル化しているので最下行の指定が通例とちょっと違うことと、フォルダパスを”\”で区切った配列を一気に反映させるためにResizeを使っているところがミソ
細かいこと書きましたがざっくりやっていることは↓↓だけ
- 引数にあるフォルダ内のファイルをFor Eachでサーチ
- SETシートで指定したファイルと拡張子の条件と照合
- 条件一致していればLISTシートにあるテーブルへ書き込む
GetSubFoler
Private Function GetSubFoler(ws As Worksheet, target_folder As String)
'======================================================================
' 再帰処理でフォルダを潜りながらそのフォルダのファイルを取得する
'======================================================================
Dim objFld As Scripting.Folder
For Each objFld In objFso.GetFolder(target_folder).SubFolders
'---フォルダ名検索に指定があったら
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
'---指定の場合一致したらファイル情報を取得する
If Range("FOLDER_MATCH_PATTERN").Value = "指定" Then
If in_array(objFld.Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = True Then
Call GetFileData(ws, objFld.Path)
End If
'---どちらにしても再帰処理はかける
Call GetSubFoler(ws, objFld.Path)
End If
'---除外の場合は不一致ならファイル情報取得して再帰処理する
If Range("FOLDER_MATCH_PATTERN").Value = "除外" Then
If in_array(objFld.Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = False Then
Call GetFileData(ws, objFld.Path)
Call GetSubFoler(ws, objFld.Path)
End If
End If
Else
Call GetFileData(ws, objFld.Path)
Call GetSubFoler(ws, objFld.Path)
End If
Next
End Function
ここでもin_arrayが登場してるのですが、条件指定を複数できるようにしてるので重宝します
ここでのポイントは再帰処理しているところだけで、これまで通りやっていることを並べると
- SETシートで指定したフォルダの条件と照合
- 一致しているもしくは条件指定していないならファイル情報を取得
- 次の階層のフォルダを同じことを繰り返す
再帰処理はその内説明ページ作ります
in_array
Private Function in_array(target_str As String, target_array As Variant, Optional match_type As String = "完全一致") As Boolean
'======================================================================
' パターンに合わせて一致判定を返す
'======================================================================
Dim arr As Variant
For Each arr In target_array
Select Case match_type
Case "完全一致"
If LCase(target_str) = LCase(arr) Then
in_array = True
Exit Function
End If
Case "部分一致"
If LCase(target_str) Like "*" & LCase(arr) & "*" Then
in_array = True
Exit Function
End If
Case "前方一致"
If LCase(target_str) Like LCase(arr) & "*" Then
in_array = True
Exit Function
End If
Case "後方一致"
If LCase(target_str) Like "*" & LCase(arr) Then
in_array = True
Exit Function
End If
Case Else
End Select
Next
in_array = False
End Function
本家のin_arrayは完全一致だけですが今回の使用目的的にも自作関数なので一致条件を分岐で作りましたが、指定の文字が配列の中にあるかをチェックする関数
Dictionary型で無理矢理取り扱えばExistsもありますが、完全一致以外も処理したいので結局自作関数がベストかと
余談 兼 フリーソフト紹介
今回せっかくVBAで作ったので分解して説明しましたが、ファイルリストを作りたいならフリーソフトのEverythingを使うと爆速で作成できます!
個人的にはWindowsの標準ソフトとして搭載してほしいくらいの便利ソフトなので興味がある方は是非!
あとがき
せっかく作ったので紹介してみましたが実のところ再帰処理さえ理解していれば9割くらい作れるお手軽プログラムに細かな設定を付け足しただけです
他にもExcelでツール作った時は同じように公開してますのでたまに覗きに来てくれると嬉しいです!
コメント