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.2

cj_mover

＃１、ｃｊです。追加レスです。

うっかり、安直過ぎました。
＃１は、「"ネコ"を含む行の先頭文字列（数字）」を返すものなので、
"ネコ"に部分一致する"ヤマネコ"等にもヒットしてしまいますから、実用的でありませんでした。
完全一致版を（性質が大きく異なる）２種、挙げておきます。
"・"や"、"が区切り文字として（確実に）（全角で）使われていることが絶対条件になります。
「Sub testA()」「Sub testC()」を実行してテストしてみてください。
（◆の行の指定は確実に、、、）

///

' ' 次行以下、標準モジュール　の先頭から　不足なく

Option Explicit

Private Const sFolPath As String = "D:\日別訪問動物\"　　'　　◆　フォルダパス&\ 正しく指定

Private Const sKeysA = "サル,イヌ,カエル,カワウソ,ライオン,ゾウ,オオカミ,トラ,ネコ,クマ,カバ"　　'　 ← テスト用便宜上の定数
Private cn As Long　　'　 ← テスト用便宜上の変数

Sub testA()
　　For cn = 0 To 10
　　　　Re8464141a
　　Next cn
End Sub
Sub Re8464141a()
　　Dim rtn　　'　　戻り値
　　Dim sKey As String　　'　　検索キーワード
　　Dim sFormatPtr As String　　'　　日付値を基に各テキストファイル名（フルパス）を整形するパターン
　　Dim sMatchPtr As String　　'　　検索キーワードを区切り文字で挟んで完全一致を図る検索パターン
　　Dim sFile As String　　'　　各テキストファイル名
　　Dim sTempLine As String　　'　　各テキストデータを行単位で読込む変数
　　Dim nlen As Long　　'　　検索キーワードの文字長
　　Dim nPos As Long　　'　　検索キーワードがヒットした桁位置
　　Dim i As Long　　'　　ループ用（日付値相当）
　　Dim nFree As Integer　　'　　テキスト読み込み用空きナンバー

　　sFormatPtr = """" & sFolPath & """yyyymmdd"".txt"""

　　sKey = Split(sKeysA, ",")(cn)　　'　　←テスト用便宜上の記述。　　◆　検索キーワード、正しく指定
　　sMatchPtr = "*・*[・、]" & sKey & "、*"
　　nlen = Len(sKey)

　　nFree = FreeFile
　　For i = Date To Date - 365 Step -1

　　　　sFile = Format(i, sFormatPtr)

　　　　If Dir(sFile) <> "" Then

　　　　　　Open sFile For Input As #nFree
　　　　　　Do While Not EOF(nFree)
　　　　　　　　' ' テキストデータを一行ずつ変数に読み込む
　　　　　　　　Line Input #nFree, sTempLine

　　　　　　　　nPos = InStr(sTempLine, sKey)
　　　　　　　　If sTempLine & "、" Like sMatchPtr Then
　　　　　　　　　　rtn = Trim$(Split(sTempLine, "・")(0))
　　　　　　　　　　Close #nFree
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Loop

　　　　　　Close #nFree
　　　　End If
　　Next i

　　Dim nR As Long
　　If IsEmpty(rtn) Then
　　　　MsgBox "notfound"
　　Else
'　　　　Debug.Print "■"; rtn; "■"; sKey; "■"; Format(i, "yyyymmdd")
　　　　With Sheets("Sheet1")　　'　　◆　シート名、正しく指定
　　　　　　nR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　　　.Cells(nR, 1) = rtn　　'　　A列　に　"何匹？"
　　　　　　.Cells(nR, 2) = sKey　　'　　B列　に　"どの動物？"
　　　　　　.Cells(nR, 3) = Format(i, "yyyymmdd")　 '　　C列　に　"いつ？"
　　　　End With
　　End If

End Sub

Sub testC()
　　For cn = 0 To 10
　　　　Re8464141c
　　Next cn
End Sub
Sub Re8464141c()
　　Dim rtn　　'　　戻り値
　　Dim oFSO As Object　　'　　As Scripting.FileSystemObject　　'
　　Dim oRegExp As Object　　'　　As VBScript_RegExp_55.RegExp　　'　　
　　Dim sKey As String　　'　　検索キーワード
　　Dim sFormatPtr As String　　'　　日付値を基に各テキストファイル名（フルパス）を整形するパターン
　　Dim sFile As String　　'　　各テキストファイル名
　　Dim sBuf As String　　'　　各テキストデータを流し込む変数
　　Dim i As Long　　'　　ループ用（日付値相当）
　　Dim flgHit As Boolean　　'　　各テキストファイルでマッチするかどうかフラグ

　　sFormatPtr = """" & sFolPath & """yyyymmdd"".txt"""

　　sKey = Split(sKeysA, ",")(cn)　　'　　←テスト用の記述。　　◆　検索キーワード、正しく指定

' ' RegExp（正規表現）
　　Set oRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
　　With oRegExp
　　　　.Global = True
　　　　.Pattern = "(^|[\r\n])[\s\t　]*([^\s\t　・]+)・[^\n]+[・、]" & sKey & "([\r\n、]|$)"
　　End With

' ' FSO（ファイルシステムオブジェクト）
　　Set oFSO = CreateObject("Scripting.FileSystemObject")　　' New Scripting.FileSystemObject

　　For i = Date To Date - 365 Step -1

　　　　sFile = Format(i, sFormatPtr)

　　　　If oFSO.FileExists(sFile) Then

　　　　　　With oFSO.GetFile(sFile).OpenAsTextStream
　　　　　　　　sBuf = .ReadAll
　　　　　　　　.Close
　　　　　　End With

　　　　　　flgHit = oRegExp.test(sBuf)
　　　　　　If flgHit Then Exit For

　　　　End If
　　Next i

　　Dim nR As Long
　　If flgHit Then
　　　　rtn = oRegExp.Execute(sBuf)(0).SubMatches(1)

'　　　　Debug.Print "■"; rtn; "■"; sKey; "■"; Format(i, "yyyymmdd")
　　　　With Sheets("Sheet1")　　'　　◆　シート名、正しく指定
　　　　　　nR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　　　.Cells(nR, 1) = rtn　　'　　A列　に　"何匹？"
　　　　　　.Cells(nR, 2) = sKey　　'　　B列　に　"どの動物？"
　　　　　　.Cells(nR, 3) = Format(i, "yyyymmdd")　 '　　C列　に　"いつ？"
　　　　End With
　　Else
　　　　MsgBox "notfound：" & sKey
　　End If

　　Set oFSO = Nothing:　　Set oRegExp = Nothing
End Sub