VBAで新しい日付順にファイルを検索するには？

ExcelのVBA初心者です。
ファイルを新しい日付のものから順番に検索したいのですが、幾ら探しても分かりませんでした。どなたか教えていただけないでしょうか？
やりたいことは、あるフォルダ内に毎日5～6個のファイルが保存されていくのですが、その中の決められたセルに指定した文字列が含まれているもの3つ場合分けしてファイルを出力したいのです。
例えば、
　ファイル名　　　セルE1の内容　　　　日付
　123.xls　　　　　”111111A”　　　　6/29 15:39:40
　456.xls　　　　　”111111N”　　　　6/29 15:35:10
　789.xls　　　　　”222222V”　　　　6/29 15:20:43
　654.xls　　　　　”222222A”　　　　6/29 14:30:21
　321.xls　　　　　”111111V”　　　　6/29 14:10:33
　951.xls　　　　　”222222N”　　　　6/28 17:52:15
　753.xls　　　　　”333333A”　　　　6/28 17:30:50
とファイルがあり、セルE1に”111111”の文字列を含むファイルを検索し、
　末尾に”V”があるもの → f(1)=321.xls
　末尾に”N”があるもの → f(2)=456.xls
　末尾に”A”があるもの → f(3)=123.xls
と出力したいのです。

分からないなりに、いろいろ調べて切り貼りしながら作ってみました。
これで一応うまくいったのですが、検索する文字列は、必ず上記例のように新しい日付の5～6ファイルの中にあり、検索対象のフォルダ内には1000個以上ファイルがあります。
上記プログラムだと読み込む順番が最後になってしまいますので、恐ろしく処理時間が掛かってしまいます。

Sub ファイル検索()
Dim buf As String, cnt As Long
Dim i As Integer
Dim wb(3)
Dim bk As String, lot As String, lt As String
Dim Path As String

Application.ScreenUpdating = False
lt = Cells(1, 5)
bk = ActiveWorkbook.Name
Path = Cells(1, 5)

buf = Dir(Path & "*.xls")
i = 1
Do While wb(1) = "" Or wb(2) = "" Or wb(3) = ""
cnt = cnt + 1
Workbooks.Open Path & buf
Select Case Cells(2, 5)
Case Is = lt & "V"
wb(1) = buf
Case Is = lt & "N"
wb(2) = buf
Case Is = lt & "A"
wb(3) = buf
End Select

Application.DisplayAlerts = False
Workbooks(buf).Close
Application.DisplayAlerts = True
buf = Dir()
Loop
For i = 1 To 3
Workbooks(bk).Sheets(1).Cells(i, 1) = "wb(" & i & ")" & "=" & wb(i)
Next i
Application.ScreenUpdating = True
End Sub

日付の新しいファイルから読み込む良い方法はないでしょうか？
Excelのバージョンは、2003です。
出来れば、2003～2010で対応できる方法があれば、ベストです。

よろしくお願い致します。

No.2 ベストアンサー 回答者： nishi6 回答日時： 2014/07/06 13:32

質問に提示されているプログラムは動いていますか？

少々疑問があります。
１．「セルE1の内容」とありますが、セルE2の内容を見ていませんか？
２．プログラム中に「lt = Cells(1, 5)」と「Path = Cells(1, 5)」があります。こうなると多数のフォルダーがあるように見えます。もしかすると階層的なフォルダー？質問の「あるフォルダ内」と食い違ってきかねません。Pathが違っているのでは？と思います。
３．プログラム中に「buf = Dir(Path & "*.xls")」という記述がありますが、これではExcel2007以降では「.xlsx、.xlsm」も抽出されます。「2003～2010で対応できる方法があれば、ベストです。」に絡んできます。今後も「xlsしか使わない」、「どちらもある」ということで対応が変わってきます。

Dir関数が返すファイルの順番については、NTFSでフォーマットされているディスクでは、ファイルが保存された順番にかかわらず、ファイル名の順番(昇順)で返ります。新しいものから読むのは難しいですね。しかし、このような仕掛けを作って、昔のファイルを修正したらどうなるんでしょうか。それが最新？ファイル名に日付や時刻を付加した方がいいような気もします。例えば、Data_20140706_185055.xlsxのような感じです。2014年7月6日18時50分55秒の意味です。


一応、提示のプログラムにとらわれずに私の理解の中で作ってみました。

１．使用するシートは「Sheet1」。プロシージャーはSheet1のコードウィンドウに貼り付ける。
２．セルE1に「最後の１文字を除いた文字列を入力」
３．G列に抽出したBook名、H列にその更新日時を出力
４．G、H列を更新日時で逆順ソート
５．G列の最初から６件を開いてセルE2を調べて３つのBook名を確定
６．３つのBook名はA1～A3に出力
７．G、H列の消去はご自由に

Bookの抽出は
　A.Dir関数の使用
　B.ファイルシステムオブジェクトを使用
の２つを書いています。今はファイルシステムオブジェクトを使用をコメントにしていますが、選んでください。２つ同時には使えません。片方をコメントで無効にします。

xls限定とxls、xlsxを２つ抽出するケースを書いているので実情に合うようにしてください。

８．「「2003～2010で対応できる方法」
当方、Excel2010です。多分2003でも動くと思いますが、確認できていません。


Sub Sample001()
　　'出力列
　　Range("A1:A3").ClearContents '結果
　　Range("G:H").ClearContents　　'ブック一覧
　　
　　Range("G1:H1") = Array("Book名", "更新日時") '表題
　　
　　'Book一覧を作成
　　Const Path As String = "C:\Users\nishi6\Documents" 'パス
　　Dim rw As Long　　'出力行

　　rw = 1
　　'**************************************
　　'Dir関数を使用
　　Dim FL As String
　　FL = Dir(Path & "\" & "*.xls") '前方一致で検索される
　　While FL <> ""
　　　　If Right(FL, 3) = "xls" Then 'xlsに限定
　　　　　　rw = rw + 1 'G列とH列に出力
　　　　　　Cells(rw, "G") = FL
　　　　　　Cells(rw, "H") = Format(FileDateTime(Path & "\" & FL), _
　　　　　　　　　　　　　　　　　　 "yyyy/mm/dd hh:mm")
　　　　End If
　　
　　　　FL = Dir
　　Wend
　　'**************************************
　　
'　　'**************************************
'　　'ファイルシステムオブジェクトを使用
'　　Dim FL As Object 'ファイル
'　　With CreateObject("Scripting.FileSystemObject")
'　　　　For Each FL In .GetFolder(Path).Files
'　　　　　　If LCase(.GetExtensionName(FL)) = "xls" Or _
'　　　　　　 LCase(.GetExtensionName(FL)) = "xlsx" Then
'　　　　　　　　rw = rw + 1 'G列とH列に出力
'　　　　　　　　Cells(rw, "G") = FL.Name
'　　　　　　　　Cells(rw, "H") = Format(FL.DateCreated, _
'　　　　　　　　　　　　　　　　　　　　 "yyyy/mm/dd hh:mm")
'　　　　　　End If
'　　　　Next
'　　End With
'　　'**************************************
　　
　　Columns("G:H").EntireColumn.AutoFit '列幅調整
　　
　　'日時で並べ替え
　　Range("G1:H" & Range("H" & Rows.Count).End(xlUp).Row) _
　　　　　　.Sort Key1:=Range("H2"), _
　　　　　　　　Order1:=xlDescending, Header:=xlYes

　　'Bookを最大6つ開いて調べる
　　Const openBook = 6　　'最大開くブック数
　　Dim It As String　　 '判定文字列の一部
　　Dim idx As Integer　　'求めるブック名のインデックス
　　Dim wb(3)　　　　　　 '求めるブック名
　　Dim elm As String　　 '開いたブックのE2セル
　　It = Cells(1, 5)
　　
　　Application.ScreenUpdating = False
　　
　　rw = 1
　　While (wb(1) = "" Or wb(2) = "" Or wb(3) = "") _
　　　　　　　　　　　　　　　　　　 And rw <= openBook
　　　　Workbooks.Open Cells(rw + 1, "G") 'Bookを開く
　　　　elm = ActiveWorkbook.Sheets(1).Cells(2, 5)
　　　　　　'内容を調べる
　　　　　　idx = 0
　　　　　　Select Case True
　　　　　　　　Case elm = It & "V": idx = 1
　　　　　　　　Case elm = It & "N": idx = 2
　　　　　　　　Case elm = It & "A": idx = 3
　　　　　　End Select
　　　　　　If idx <> 0 Then wb(idx) = Cells(rw + 1, "G")

　　　　ActiveWorkbook.Saved = True
　　　　ActiveWorkbook.Close　　　　　　'Bookを閉じる
　　
　　　　rw = rw + 1
　　Wend

　　'出力
　　For rw = 1 To 3
　　　　Cells(rw, 1) = "wb(" & rw & ")" & "=" & wb(rw)
　　Next
　　
　　'Range("G:H").ClearContents　　'ブック一覧
　　Application.ScreenUpdating = True
End Sub

この回答へのお礼

ご丁寧にプログラムまで示していただき、ありがとうございました。
「lt = Cells(1, 5)」と「Path = Cells(1, 5)」は、誤記でした。すいません。
正しくは、「lt = Cells(2, 5)」でした。
(試行錯誤しているうちに、写し間違えてました)
そのあたり、含め少し修正したら、思った通りの結果になりました。
プログラムの中で、読み込む順番が変えられるかと思ってましたが、ワークシートに書いて並び替えるのが早いんですね。
勉強になりました。

お礼日時：2014/07/07 22:48

No.3 回答者： JazzCorp 回答日時： 2014/07/07 15:00

Option Explicit

'Const xPath = "i:\!\"
Const xExt = ".xls"
Dim WSH As Object
Dim wExec As Object
Dim Cmd As String
Dim Result As String
Dim xPath As String
Dim xFileName As String
Dim jj As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long
Sub ファイル検索()
Dim cnt As Long
Dim i As Integer
Dim wb(3)
Dim bk As String, lot As String, lt As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False

bk = ActiveWorkbook.Name
'Setup please !!
xPath = ThisWorkbook.Sheets(1).Cells(2, "E")
lt = ThisWorkbook.Sheets(1).Cells(1, "E")
Call OLFA
nn = 2

'xFileName = Dir(xPath & "*.xls")

'Do While wb(1) = "" Or wb(2) = "" Or wb(3) = ""
Do
xFileName = ThisWorkbook.Sheets("tmp").Cells(nn, "D")
If (xFileName = Empty) Then Exit Do
If (wb(1) <> Empty) And (wb(2) <> Empty) And (wb(3) <> Empty) Then Exit Do
' 読み取り専用/自動リンク更新無しで開く
Workbooks.Open Filename:=(xPath & xFileName) _
, ReadOnly:=True _
, UpdateLinks:=0
Select Case Cells(1, "E")
Case Is = lt & "V"
If (wb(1) = Empty) Then
wb(1) = xFileName
End If
Case Is = lt & "N"
If (wb(2) = Empty) Then
wb(2) = xFileName
End If
Case Is = lt & "A"
If (wb(3) = Empty) Then
wb(3) = xFileName
End If
End Select

Application.DisplayAlerts = False
Workbooks(xFileName).Close (False)
' xFileName = Dir()
nn = nn + 1
Loop
ThisWorkbook.Activate
For i = 1 To 3
If (wb(i) <> Empty) Then
Workbooks(bk).Sheets(1).Cells(i, "A") = "wb(" & i & ")" & "=" & wb(i)
Else
Workbooks(bk).Sheets(1).Cells(i, "A") = "File not found !!"
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub OLFA()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WSH = CreateObject("Wscript.Shell")
'Cmd = "Dir i:\!\*.xls /-C /S /O:-D /T:W /4"
Cmd = "Dir " & xPath & "*" & xExt & " /-C /O:-D /T:W /4"
Set wExec = WSH.Exec("%ComSpec% /c " & Cmd)
Do While wExec.Status = 0
DoEvents
Loop
Result = wExec.StdOut.ReadAll
'ActiveSheet.UsedRange.ClearContents
kk = InStr(Result, vbCrLf)
If (kk > 0) Then
Call Cutter
End If
'Call Sweeper
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set wExec = Nothing
Set WSH = Nothing
End Sub

'Private Function Cutter(ByRef line)
Private Function Cutter()
Const xHead = "Date Time Size Name FileDateTime"
Dim xResult
Dim xResults
'Worksheets.Add before:=Worksheets(1)
ThisWorkbook.Activate
Worksheets("tmp").Activate
'ActiveSheet.UsedRange.ClearContents
xResults = Split(xHead)
Cells(1, "A").Resize(, UBound(xResults) + 1) = Split(xHead)
xResult = Split(Result, vbCrLf)
nn = 2
For mm = 0 To UBound(xResult)
If (xResult(mm) <> Empty) Then
xResults = Split(xResult(mm))
If IsDate(xResults(0)) Then
kk = 1
For jj = 0 To UBound(xResults)
If (xResults(jj) <> Empty) Then
Cells(nn, kk) = xResults(jj)
kk = kk + 1
End If
Next
If (kk > 5) Then
Cells(nn, 5).Resize(, kk - 1).Value = Empty
kk = InStr(Result, Cells(nn, 4).Value)
If (kk > 0) Then
Result = Mid(Result, kk, Len(Result))
Cells(nn, 4).Value = Mid(Result, 1, InStr(Result, xExt) + 3)
End If
End If
xFileName = xPath & Cells(nn, 4).Value
Cells(nn, 5) = FileDateTime(xFileName)
nn = nn + 1
End If
End If
Next
Columns("A:E").AutoFit
End Function

この回答へのお礼

すごいプログラムを作っていただき、大変感謝しております。
ただ、今の私には理解するにはちょっとハードルが高かったです。すいません。
しかし、せっかく作っていただいたので、がんばって理解出来るよう勉強します。
ありがとうございました。

お礼日時：2014/07/07 22:51

No.1 回答者： f272 回答日時： 2014/07/05 16:44

ループをまわしながら，ファイル名とその最終更新日時を配列に保存して(ワークシートに書いてもよい)，その後，ソートを行って日付の新しい順にファイル名を並び替えます。

そしてその順にファイルを開いてセルの中身を確認すればよいでしょう。

最終更新日時はFileDateTime関数で取得できます。

この回答へのお礼

早速のご回答、ありがとうございました。
一発で出来る方法あるかと思ったのですが、並び替えが必要なんですね。
勉強になりました。

お礼日時：2014/07/07 22:29