
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ベストアンサー
- 回答日時:
質問に提示されているプログラムは動いていますか?
少々疑問があります。
1.「セルE1の内容」とありますが、セルE2の内容を見ていませんか?
2.プログラム中に「lt = Cells(1, 5)」と「Path = Cells(1, 5)」があります。こうなると多数のフォルダーがあるように見えます。もしかすると階層的なフォルダー?質問の「あるフォルダ内」と食い違ってきかねません。Pathが違っているのでは?と思います。
3.プログラム中に「buf = Dir(Path & "*.xls")」という記述がありますが、これではExcel2007以降では「.xlsx、.xlsm」も抽出されます。「2003~2010で対応できる方法があれば、ベストです。」に絡んできます。今後も「xlsしか使わない」、「どちらもある」ということで対応が変わってきます。
Dir関数が返すファイルの順番については、NTFSでフォーマットされているディスクでは、ファイルが保存された順番にかかわらず、ファイル名の順番(昇順)で返ります。新しいものから読むのは難しいですね。しかし、このような仕掛けを作って、昔のファイルを修正したらどうなるんでしょうか。それが最新?ファイル名に日付や時刻を付加した方がいいような気もします。例えば、Data_20140706_185055.xlsxのような感じです。2014年7月6日18時50分55秒の意味です。
一応、提示のプログラムにとらわれずに私の理解の中で作ってみました。
1.使用するシートは「Sheet1」。プロシージャーはSheet1のコードウィンドウに貼り付ける。
2.セルE1に「最後の1文字を除いた文字列を入力」
3.G列に抽出したBook名、H列にその更新日時を出力
4.G、H列を更新日時で逆順ソート
5.G列の最初から6件を開いてセルE2を調べて3つのBook名を確定
6.3つのBook名はA1~A3に出力
7.G、H列の消去はご自由に
Bookの抽出は
A.Dir関数の使用
B.ファイルシステムオブジェクトを使用
の2つを書いています。今はファイルシステムオブジェクトを使用をコメントにしていますが、選んでください。2つ同時には使えません。片方をコメントで無効にします。
xls限定とxls、xlsxを2つ抽出するケースを書いているので実情に合うようにしてください。
8.「「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)」でした。
(試行錯誤しているうちに、写し間違えてました)
そのあたり、含め少し修正したら、思った通りの結果になりました。
プログラムの中で、読み込む順番が変えられるかと思ってましたが、ワークシートに書いて並び替えるのが早いんですね。
勉強になりました。
No.3
- 回答日時:
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
すごいプログラムを作っていただき、大変感謝しております。
ただ、今の私には理解するにはちょっとハードルが高かったです。すいません。
しかし、せっかく作っていただいたので、がんばって理解出来るよう勉強します。
ありがとうございました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
今、見られている記事はコレ!
-
弁護士が解説!あなたの声を行政に届ける「パブリックコメント」制度のすべて
社会に対する意見や不満、疑問。それを発信する場所は、SNSやブログ、そしてニュースサイトのコメント欄など多岐にわたる。教えて!gooでも「ヤフコメ民について」というタイトルのトピックがあり、この投稿の通り、...
-
弁護士が語る「合法と違法を分けるオンラインカジノのシンプルな線引き」
「お金を賭けたら違法です」ーーこう答えたのは富士見坂法律事務所の井上義之弁護士。オンラインカジノが違法となるかどうかの基準は、このように非常にシンプルである。しかし2025年にはいって、違法賭博事件が相次...
-
釣りと密漁の違いは?知らなかったでは済まされない?事前にできることは?
知らなかったでは済まされないのが法律の世界であるが、全てを知ってから何かをするには少々手間がかかるし、最悪始めることすらできずに終わってしまうこともあり得る。教えてgooでも「釣りと密漁の境目はどこです...
-
カスハラとクレームの違いは?カスハラの法的責任は?企業がとるべき対応は?
東京都が、客からの迷惑行為などを称した「カスタマーハラスメント」、いわゆる「カスハラ」の防止を目的とした条例を、全国で初めて成立させた。条例に罰則はなく、2025年4月1日から施行される。 この動きは自治体...
-
なぜ批判コメントをするの?その心理と向き合い方をカウンセラーにきいた!
今や生活に必要不可欠となったインターネット。手軽に情報を得られるだけでなく、ネットを介したコミュニケーションも一般的となった。それと同時に顕在化しているのが、他者に対する辛らつな意見だ。ネットニュース...
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
複数行の文字列を変数として使...
-
正規表現を使って、日英の2行...
-
VBAで新しい日付順にファイルを...
-
ある文字列を含む行の抽出
-
ランレングス符号化を用いた符...
-
access vbaでCSVファイルを文...
-
大量のフォルダからひとつのフ...
-
コマンドプロンプトの「%1」と...
-
コマンドプロンプトのエラーに...
-
バッチでテキストファイルから...
-
.txtではなく.logの方が良いの...
-
多数のサブディレクトリ内のフ...
-
binファイルを解凍したいの...
-
これってパソコンの最適化が完...
-
複数エクセルファイルの合成
-
VBAでワークシートを引数として...
-
win10の「フォト」で、「次へ」...
-
一括でフォルダと同じ名前にフ...
-
バッチファイル 文字列にスペ...
-
[teraterm] waitコマンドで停止...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
ある文字列を含む行の抽出
-
VBAでPowerPointからExcelにデ...
-
特定フォルダ内のテキストファ...
-
BCPユーティリティの使用法_...
-
Excel.VBA テキストファイルを...
-
access vbaでCSVファイルを文...
-
VB6側からテキストファイルをク...
-
VBAで新しい日付順にファイルを...
-
時間短縮のために、テキストフ...
-
fortranでのcsvファイルを出力...
-
複数行の文字列を変数として使...
-
ソースコードの差分がある行番...
-
テキストファイルの行頭に文字...
-
ページレイアウトをHTMLファイ...
-
unicode文字列(日本語)のファイ...
-
複数のCSVの指定行だけを残し、...
-
C言語でのファイルの読み込み方
-
正規表現を使って、日英の2行...
-
VBScriptについて教えてください!
-
VBAで任意のフォルダ内のファイ...
おすすめ情報