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も見ています
-
準・究極の選択
「年収1000万円で一生カレーライス」か 「年収180万円で毎日何でも食べ放題」 あなたはどちらを選びますか?
-
フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
あなたが普段思っている「これまだ誰も言ってなかったけど共感されるだろうな」というあるあるを教えてください
-
映画のエンドロール観る派?観ない派?
映画が終わった後、すぐに席を立って帰る方もちらほら見かけます。皆さんはエンドロールの最後まで観ていきますか?
-
海外旅行から帰ってきたら、まず何を食べる?
帰国して1番食べたくなるもの、食べたくなるだろうなと思うもの、皆さんはありますか?
-
天使と悪魔選手権
悪魔がこんなささやきをしていたら、天使のあなたはなんと言って止めますか?
-
Dir関数で読み取り順を操作できる?
Visual Basic(VBA)
-
EXCEL(VBA)で指定フォルダ内の最新ファイル名を取得したい
Excel(エクセル)
-
VBAで保存しないで閉じると空のBookが残る
Excel(エクセル)
-
-
4
ファイル名「1.jpg ~10.jpg~」のソート
Visual Basic(VBA)
-
5
VBA 最新のフォルダ取得
Excel(エクセル)
-
6
VBScriptでファイルの日時順(降順)で並び替えて一覧を出力したい。
その他(プログラミング・Web制作)
-
7
エクセル:マクロ「Application.CutCopyMode = False」って?
Excel(エクセル)
-
8
VBAで行うフォルダ・ファイル検索順について
Visual Basic(VBA)
-
9
VBAでのファイル名と更新日(作成日)の抽出
Visual Basic(VBA)
-
10
VBAでファイルを開くときにファイル名でワイルドカードを使用したいです
その他(プログラミング・Web制作)
-
11
EXCEL VBAで全選択範囲の解除
Excel(エクセル)
-
12
エクセルVBAでセルに入力したパスでブックを開く
Excel(エクセル)
-
13
private subモジュールを他のモジュールから呼び出して使う方法を教えてください(-.-)
Visual Basic(VBA)
-
14
エクセルVBAでオートフィルター最上行を取得するには
Excel(エクセル)
-
15
エクセルVBAで5行目からオートフィルタモードに設定したいたい
Excel(エクセル)
-
16
エクセルVBAでUserFormを起動した時
Excel(エクセル)
-
17
ExcelVBAで質問です。Workbook_openイベントが発生し
その他(Microsoft Office)
-
18
配列の値を置換するにはどうすればいいでしょう?
Excel(エクセル)
-
19
エクセルVBAで手差しトレイを指定させたい。
Excel(エクセル)
-
20
Excel VBAでのWorksheet_Changeが動作しない原因
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excel.VBA テキストファイルを...
-
VBAでPowerPointからExcelにデ...
-
バッチでiniファイルの編集
-
A列をテキストファイル名に、B...
-
テキストファイルを直接置換す...
-
複数行の文字列を変数として使...
-
iniファイルとの比較(iniファイ...
-
unicode文字列(日本語)のファイ...
-
特定フォルダ内のテキストファ...
-
VBAで新しい日付順にファイルを...
-
ExcelVBAで以下のマクロを作成...
-
BCPユーティリティの使用法_...
-
VB6側からテキストファイルをク...
-
access vbaでCSVファイルを文...
-
fortranでのcsvファイルを出力...
-
H8マイコンにおける演算結果の...
-
ある文字列を含む行の抽出
-
excelにテキストファイルの指定...
-
コマンドプロンプトの「%1」と...
-
コマンドプロンプトのエラーに...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
特定フォルダ内のテキストファ...
-
複数行の文字列を変数として使...
-
テキストファイルの行頭に文字...
-
VB6側からテキストファイルをク...
-
BCPユーティリティの使用法_...
-
fortranでのcsvファイルを出力...
-
テキストファイルを直接置換す...
-
VBAで新しい日付順にファイルを...
-
access vbaでCSVファイルを文...
-
バッチでiniファイルの編集
-
ある文字列を含む行の抽出
-
RandomとBinaryモードの違い
-
VBAでPowerPointからExcelにデ...
-
Excel.VBA テキストファイルを...
-
A列をテキストファイル名に、B...
-
VBAで任意のフォルダ内のファイ...
-
時間短縮のために、テキストフ...
-
unicode文字列(日本語)のファイ...
-
複数のCSVの指定行だけを残し、...
-
ExcelVBAで以下のマクロを作成...
おすすめ情報