VBAでテキストファイル中の文字列を抽出したい

質問

説明が冗長になりそうですが・・・

たとえば「日別訪問動物」というフォルダがあるとします。
その中には、
20140206.txt
20140205.txt
20140204.txt　・・・
と、日別に名前がつけられたテキストファイルが複数入っています。
それぞれのテキストファイルは、以下のような内容が書き込まれています。
　○20140206.txtの中身
　今日わが家を訪問してきた動物は次の通りです。
　3匹・・・イヌ、カエル
　2匹・・・カワウソ
　1匹・・・ライオン、ゾウ、オオカミ

　○20140205.txtの中身
　今日わが家を訪問してきた動物は次の通りです。
　5匹・・・トラ
　2匹・・・ネコ、イヌ
　1匹・・・クマ

　○20140204.txtの中身
　今日わが家を訪問してきた動物は次の通りです。
　3匹・・・ネコ、ライオン
　1匹・・・カバ

このときに、”最新の日付で、ネコが訪れてきたときのネコの数”をエクセルVBAで抽出し、任意のセル（たとえばA1など）に貼りつけたいと考えています。

上記の例では、「2匹」を抽出したいと考えています（2月5日に訪れたネコ2匹）。

どのようにすればうまくいくでしょうか？

回答No.3

30246kiku

私もやってみました

操作として、A列のどこかに「ネコ」と入力したら、
その横、B列に日付を、C列にｘ匹　を表示するものです。

フォルダの対象ファイル一覧を作った後、直近から Open 探す方法なので
ファイル数が多ければ、それなりに遅くなると思います。
ファイル内の解釈は、
１行づつ読み込みます
「・」が無い行はスキップ
「・」があれば、「・」区切りの最後を「、」区切りで
その区切ったものがA列に入力されたものだったら・・・・
という流れになっています。
（ベタな処理と思います）

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim sKey As String
　Dim oFso As Object
　Dim sS As String
　Dim sBuf As String
　Dim sAry() As String
　Dim v As Variant
　Const CPATH = "D:\Hoge\日別訪問動物\"
　Const CCHKMOJI = "・"
　Const CSEPMOJI = "、"
　Const adVarChar = 200
　Const adUseClient = 3
　Const adOpenStatic = 3
　Const adLockOptimistic = 3

　With Target
　　If ((.Count <> 1) Or (.Column <> 1)) Then Exit Sub
　　sKey = .Value
　　If (Len(sKey) = 0) Then Exit Sub
　　Application.EnableEvents = False
　　.Offset(, 1) = ""
　　.Offset(, 2) = ""
　　Application.EnableEvents = True
　End With

　Set oFso = CreateObject("Scripting.FileSystemObject")
　With CreateObject("ADODB.Recordset")
　　.Fields.Append "F1", adVarChar, 255
　　.CursorLocation = adUseClient
　　.CursorType = adOpenStatic
　　.LockType = adLockOptimistic
　　.Open
　　For Each v In oFso.GetFolder(CPATH).Files
　　　If (oFso.GetExtensionName(v.Name) = "txt") Then
　　　　sS = oFso.GetBaseName(v.Name)
　　　　If ((Len(sS) = 8) And (Not sS Like "*[!0-9]*")) Then
　　　　　.AddNew
　　　　　.Fields(0) = v.Name
　　　　　.Update
　　　　End If
　　　End If
　　Next
　　If (.RecordCount > 0) Then
　　　.Sort = "F1 DESC"
　　　Do While (Not .EOF)
　　　　sS = .Fields(0)
　　　　With oFso.OpenTextFile(CPATH & sS)
　　　　　Do While (Not .AtEndOfStream)
　　　　　　sBuf = .ReadLine
　　　　　　If ((InStr(sBuf, CCHKMOJI) > 0) _
　　　　　　　And (InStr(sBuf, sKey) > 0)) Then
　　　　　　　sAry = Split(Trim(sBuf), CCHKMOJI)
　　　　　　　For Each v In Split(sAry(UBound(sAry)), CSEPMOJI)
　　　　　　　　If (v = sKey) Then
　　　　　　　　　Application.EnableEvents = False
　　　　　　　　　With Target
　　　　　　　　　　.Offset(, 1) = Format(oFso.GetBaseName(sS), "@@@@/@@/@@")
　　　　　　　　　　.Offset(, 2) = sAry(0)
　　　　　　　　　End With
　　　　　　　　　Application.EnableEvents = True
　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　　Next
　　　　　　　If (Not IsEmpty(v)) Then Exit Do
　　　　　　End If
　　　　　Loop
　　　　　.Close
　　　　End With
　　　　If (Not IsEmpty(v)) Then Exit Do
　　　　.MoveNext
　　　Loop
　　End If
　　.Close
　End With
　Set oFso = Nothing
End Sub