マクロで文字検索と書き出し

質問

Excelのマクロで各フォルダ内にあるテキストファイルに特定文字が含まれていたら
そのテキストファイルがあるフォルダ名をセルB1に書きだすというマクロを組みたいです。

Aというフォルダ内に

20150328
20150410
20160322
・・・・
・・・・
・・・・
20160412
というようなフォルダ名のついたフォルダが300個近くあります。

300個近いフォルダ内にはテキストファイルがあり（ないものある）
そのテキストファイル内にセルA1で入力されている文字と同じ物があれば(完全一致ではなく一部一致でよい)
一番最初に見つけたそのテキストファイルが入っているフォルダ名をB1に
書きだす方法が知りたいです。

例えば上記の例で言うと
検索した文字　【計測】だとします。
20150328
20150410
20160322
このフォルダ内のテキストファイルには全て　計測　とい文字が含まれていますが
名前の順番からすると20150328のフォルダが最初なので
そのフォルダ名をB1に書きだすという感じです。

また、これは出来ればでいいのですが
300個近いフォルダを全て調べていくと時間が掛ってしまうので
セルA2に日付を入力しておき
上記のマクロを実行すると、セルA2に入力した日付以降に作成されたフォルダから
検索を始めるようにしたいです。

このような事が出来るかわかりませんが、宜しくお願いします。

回答No.3

imogasi

したいことだけ質問に長々と書いて、コードを作ってくれというふうな丸投げになっている。本やWEBで、どれほど本質問をやろうとして調べたのか。どこで行きずまったか。
仕事がらみらしいが、実力以上のことをしようとしているのではないか。
周りにチェックして教えてくれる人がいない環境で、仕事に関係した処理をするのは危険と思う。
そもそも、FSO（FileSystemObject)の本や記事を読んで勉強して質問しているのか。
「ＶＢＳｃriptポケットリファレンス」（技術評論社）には、
・ファイルやフォルダの作成日を調べたい
という解説がある。
作成日の前後で検索対象から外したいらしいが、フォルダ名（の一部）は日付の文字列が入っているのか。入ってなければＦＳＯで作成日を調べればよい。・
ーー
・フォルダ内のすべてのファイルを参照したい
という解説も（上掲書に）ある。
ＦｏｒＥａｃｈでできる。
＝＝
データの構成単位として
（１）レコード
（２）ファイル
（３）フォルダ
の中で、特別に作成されて公開されているソフト（Ｖｅｃｔｏｒにあるものなど）なら（３）のフォルダの全ファイルを調べてくれるものもあるようだが、見つけて表示してくれるだけで、その後のＶＢＡでの作業ができない（そういう用途に作られていない）。
だから（２）ぐらいが最上レベルだろう。
（２）は「ファイル全体の文字列を読みこみたい」ReadAll（上掲書にあるよ）
によって、読み込んだ全文の検索をすればよいと思う。
それを、フォルダ内の全ファイルに当てはめて繰り返せばよい。
参考に
Sub test01()
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Txt = FSO.OpenTextFile("C:\Users\ＸＸＸ\Documents\テキストファイル例１.txt")
'全文読み込み
buf_strTxt = Txt.ReadAll
Txt.Close
'探索処理
s = 1
Do
p = InStr(s, buf_strTxt, "東京")
If p <> 0 Then
MsgBox Mid(buf_strTxt, p , 10)
s = p + 1
End If
Loop While p <> 0
End Sub
このテスト例では、「東京」という文字列が出てきたら、（その都度に）東京も含めた（続く）１０文字を表示している。こういうのが使えないか。
ーー
上記では書籍の例を出したが、ＷＥＢでも記事はたくさんある。ＶＢＡをやるなら、VBScriptの本とIEのVBAがらみの本は常備しておくべきだと思う。

回答No.2

ushi2015

こんにちは
フォルダは日付でしょうか？
早い日の順番に検索するのは面倒なので、1日ずつ存在チェックして、
Sub test()
　　Dim FSO　　As Object
　　Dim fld　　As Variant
　　Dim d　　 As Variant
　　Dim i　　 As Long
　　Dim MaxF As Long
　　Dim MinF As Long
　　Dim v　　 As Long
　　Dim buf　　As String
　　Dim target As String

　　Const MinD As Date = #1/1/2015#
　　Const Fld1 As String = "G:\A\"
　　Const Fext As String = "*.txt"

　　MaxF = CLng(Format(Now(), "yyyymmdd"))
　　MinF = CLng(Format(MinD, "yyyymmdd"))

　　target = Range("A1").Value
　　Range("B1") = ""

　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　Do Until v > MaxF
　　　　v = CLng(Format(DateAdd("d", i, MinD), "yyyymmdd"))
　　　　i = i + 1
　　　　If Dir(Fld1 & v, vbDirectory) <> "" Then
　　　　　　Set fld = FSO.GetFolder(Fld1 & v)
　　　　　　If fld.DateLastModified > DateValue(Range("A2")) Then
　　　　　　　　For Each d In fld.Files
　　　　　　　　　　If d.DateLastModified > DateValue(Range("A2")) _
　　　　　　　　　　　　　　　　　　　　　　And d.Name Like Fext Then
　　　　　　　　　　　　With FSO.GetFile(d).OpenAsTextStream
　　　　　　　　　　　　　　buf = .ReadAll
　　　　　　　　　　　　　　If InStr(1, buf, target, vbTextCompare) <> 0 Then
　　　　　　　　　　　　　　　　Range("B1") = fld.Name
　　　　　　　　　　　　　　　　Exit Do
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　.Close
　　　　　　　　　　　　End With

　　　　　　　　　　End If
　　　　　　　　Next d
　　　　　　End If
　　　　End If
　　Loop
End Sub
フォルダ数や、テキストファイルのサイズによっては遅くて使い物に
ならないかも・・・

回答No.1

kkkkkm

http://www.moug.net/tech/exvba/0060027.html
http://officetanaka.net/excel/vba/tips/tips36.htm

こちらを参考にして作成してください。