No.1528　条件に一致するファイル一覧を出力　その１

毎度おなじみ、わかってる人にもわからない人にも役に立たないシリーズw
あるフォルダの下にあるJPGファイルの一覧を作りたい、と。職場でうだうだした流れをメモっておく。

はじめに

まずコチラのコードをお借りしてベース作ったぞ
blog.jmiri.net

ちょーっとだけ手を入れたコードを晒す

コメントまでそのままでさーせん(；´Д｀)

Option Explicit
Sub setFileList(searchPath)
Dim startCell As Range
Dim maxRow As Long
Dim maxCol As Long
Set startCell = Cells(5, 2) 'このセルから出力し始める
startCell.Select
 'シートをいったんクリア
maxRow = startCell.SpecialCells(xlLastCell).Row
maxCol = startCell.SpecialCells(xlLastCell).Column
If startCell.Row < maxRow Then
Range(startCell, Cells(maxRow, maxCol)).ClearContents
End If
Call getFileList(searchPath)
startCell.Select
End Sub
Sub getFileList(searchPath)
Dim FSO As New FileSystemObject
Dim objFiles As File
Dim objFolders As Folder
Dim separateNum As Long
 'サブフォルダ取得
For Each objFolders In FSO.GetFolder(searchPath).SubFolders
Call getFileList(objFolders.Path)
Next
 'ファイル名の取得
For Each objFiles In FSO.GetFolder(searchPath).Files
Dim myfile As String
Dim mypath As String
separateNum = InStrRev(objFiles.Path, "\")
 'セルにパスとファイル名を書き込む
mypath = Left(objFiles.Path, separateNum - 1)
myfile = Right(objFiles.Path, Len(objFiles.Path) - separateNum)
If myfile Like "*.jpg" Or myfile Like "*.JPG" Then
ActiveCell.Value = mypath
ActiveCell.Offset(0, 1).Value = myfile
ActiveCell.Offset(0, 2).Value = FileDateTime(objFiles)
ActiveCell.Offset(0, 3).Value = Format((FileLen(objFiles) / 1024), "#.0")
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub
Sub pushButton()
Dim t1, t2
t1 = Timer
Call setFileList(Cells(2, 2))   'フォルダパスを入力するセル
t2 = Timer
MsgBox (Format(t2 - t1, "0.0秒かかったよ"))
End Sub

実行結果

f:id:elve:20180301182427p:plain

早くしたい

さて、我々世代でファイル一覧といえばdirコマンドが使いたくなるでしょ？　しょ？
先に言っておくと、これはすげー早くなったがunicodeのファイル名があって死んだ。
誰だよ「❀」とかファイル名につけてる奴・・・。

excel-ubara.com
を参考に別関数を作って試してみる。参考にっつーか丸写し。

Sub getFileListDir(searchPath)
Dim i As Long
Dim aryDir() As String
Dim aryFile() As String
Dim strName As String
i = 0
ReDim aryDir(i)
aryDir(i) = searchPath 'フォルダをここで指定
 'まずは、指定フォルダ以下の全サブフォルダを取得し、配列aryDirに入れます。
Do
strName = Dir(aryDir(i) & "\", vbDirectory)
Do While strName <> ""
If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then
If strName <> "." And strName <> ".." Then
ReDim Preserve aryDir(UBound(aryDir) + 1)
aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName
End If
End If
strName = Dir()
Loop
i = i + 1
If i > UBound(aryDir) Then
Exit Do
End If
Loop
 '配列aryDirの全フォルダについて、ファイルを取得し、配列aryFileに入れます。
ReDim aryFile(0)
For i = 0 To UBound(aryDir)
strName = Dir(aryDir(i) & "\*.jpg")
Do While strName <> ""
If aryFile(0) <> "" Then
ReDim Preserve aryFile(UBound(aryFile) + 1)
End If
aryFile(UBound(aryFile)) = aryDir(i) & "\" & strName
 '実行結果が分かりやすいように、テスト的にセルに書き出す場合
Cells(UBound(aryFile) + 5, 2) = aryFile(UBound(aryFile))
strName = Dir()
Loop
Next
End Sub