#VBA100本ノック 66本目
エクセルの神髄 の中の人がツイッターで行っている VBA100本ノック の66本目の解答記事です。
#VBA100本ノック 66本目
— エクセルの神髄 (@yamaoka_ss) January 13, 2021
ブック自身のあるフォルダ以下の全サブフォルダを検索し、自身と同一名称(拡張子含めて)のファイルを探してください。
同一名称のファイルが見つかったら、シートに出力してください。
・A列:フルパス
・B列:更新日時
・C列:ファイルサイズ
※シートは任意
'Shell.Application を使った再帰ファイル探索処理及び、 'ADODB.Recordset を使ったセル出力のサンプル。 'ExcelのVBA上で実行し、出力先のワークシートを最前面にしていること。 '必要な参照設定。 'Imports Shell32 = Microsoft Shell Controls And Automation 'Imports ADODB = Microsoft ActiveX Data Objects 6.1 Library Public Sub VBA100Knock66() 'https://twitter.com/yamaoka_ss/status/1349222275820605442 'https://excel-ubara.com/vba100/VBA100_066.html Dim appShell As Shell32.Shell Set appShell = VBA.Interaction.CreateObject("Shell.Application") Dim rs As ADODB.Recordset Set rs = RecurseFileSeacrh( _ appShell.Namespace(ThisWorkbook.Path), _ ThisWorkbook.Name _ ) '自身を除外する。 rs.Filter = "[Path] <> #" & ThisWorkbook.FullName & "#" If rs.RecordCount = 0 Then Exit Sub Dim ws As Excel.Worksheet Set ws = ActiveCell.Worksheet 'Recordset のフィールド数と同じ列数のテーブルを作成。 With ws.ListObjects.Add(xlSrcRange, ws.Cells.Resize(1, rs.Fields.Count), , xlYes) With .HeaderRowRange Dim recordFieldNames() As Variant recordFieldNames = NamesOfField(rs.Fields) 'ヘッダーにフィールド名を設定。 .Value() = recordFieldNames 'データ範囲に Recordset の最初から以降全部の値を設定。 .Offset(1).Resize(rs.RecordCount).Value() = _ .Application.WorksheetFunction.Transpose( _ rs.GetRows( _ Rows:=ADODB.GetRowsOptionEnum.adGetRowsRest, _ Start:=ADODB.BookmarkEnum.adBookmarkFirst, _ Fields:=recordFieldNames _ ) _ ) End With '.HeaderRowRange '大きさ調整。 With .Range .ColumnWidth = 100 .Rows.AutoFit .Columns.AutoFit End With End With End Sub '汎用性は低い。 'inDirectory :検索の起点となる Shell32.Folder3 オブジェクト。Shell32.Shell の Namespace メソッドなどで取得できる。 'inFileNamePattern :探索したいファイル名のパターン。FolderItems3.Filter に渡されるので動作はよく確認すること。 'refRecordset :省略可。結果を格納する ADODB.Recordset。既存の Recordset に結果を追記したい場合は設定する。 Private Function RecurseFileSeacrh( _ ByVal inDirectory As Shell32.Folder3, _ ByVal inFileNamePattern As String, _ Optional ByRef refRecordset As ADODB.Recordset _ ) As ADODB.Recordset '返り値の Recordset の用意。 If refRecordset Is Nothing Then Set refRecordset = VBA.Interaction.CreateObject("ADODB.Recordset") With refRecordset.Fields .Append "Path", adBSTR .Append "ModifyDate", adDate .Append "Size", adInteger End With refRecordset.Open End If Set RecurseFileSeacrh = refRecordset 'FolderItems3.Filterの1個目の引数に指定する定数。 'https://docs.microsoft.com/en-us/windows/win32/api/shobjidl_core/ne-shobjidl_core-_shcontf Const SHCONTF_FOLDERS = &H20& 'フォルダのみを探す場合。 Const SHCONTF_NONFOLDERS = &H40& 'ファイルのみを探す場合。 'inDirectory 直下のファイル・フォルダ群の一覧を取得。 Dim itms As Shell32.FolderItems3 Set itms = inDirectory.Items() '名前が inFileNamePattern に一致するファイルのみにする。 'ワイルドカードを考慮しなくていいのであれば`inDirectory.ParseName()`を使う手もある。 itms.Filter SHCONTF_NONFOLDERS, inFileNamePattern '中の要素を列挙して Recordset に追加。 Dim f As Shell32.FolderItem For Each f In itms Call refRecordset.AddNew( _ VBA.[_HiddenModule].Array("Path", "ModifyDate", "Size"), _ VBA.[_HiddenModule].Array(f.Path, f.ModifyDate, f.Size) _ ) Next f 'フォルダーのみにフィルター。 itms.Filter SHCONTF_FOLDERS, "*" '各フォルダーについて再帰。 For Each f In itms Call RecurseFileSeacrh( _ f.GetFolder, _ inFileNamePattern, _ refRecordset _ ) Next f End Function 'Field の Name を格納した配列を作成する(簡易版)。 Private Function NamesOfField(ByVal inFields As ADODB.Fields) As Variant() Dim v() As Variant ReDim v(0 To inFields.Count - 1) Dim i As Long i = LBound(v) Dim f As ADODB.Field For Each f In inFields v(i) = f.Name i = i + 1 Next f Let NamesOfField = v End Function
その他関連ツイート
はてなブログに投稿しました #はてなブログ
— いみひと (@nukie_53) January 13, 2021
VBA100本ノック66本目 - imihitoのブログ https://t.co/iky3rVtcjK
個人的な意見
— いみひと (@nukie_53) January 13, 2021
Dir:内部で状態を持つ・扱えない文字があるという仕様自体の問題はあるものの、VBA組み込みという大きなアドバンテージ(ただし、自分は使わない)
FSO:各種便利なメソッドがあり汎用性が高い。オブジェクトブラウザを見れば大体の機能は使える。一番よく使う https://t.co/LpCSmxSTi5
ファイル列挙の速度、という観点からすると
— いみひと (@nukie_53) January 13, 2021
FileSystemObjectよりは早く、WIndows APIよりは簡単なShell.Applicationも自分は推しています https://t.co/TAQhH4tUmn