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

回答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

回答No.1

cj_mover

こんにちは。

比較的ベーシックなやり方で、、、。

（◆の行は運用に合わせて正しく指定。さもないとエラー。）
（△の行は必要に合わせる為のオプション。）

Sub Re8464141()

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

　　Dim rtn　　'　　戻り値
　　Dim arrS() As String　　'　　テキストを行ごとに区切って配列として格納
　　Dim sKey As String　　'　　検索キーワード
　　Dim sCurDir As String　　'　　現在のフォルダパスを確保
　　Dim sFile As String　　'　　各テキストファイルのファイル名
　　Dim sBuf As String　　'　　各テキストファイルのテキスト全文
　　Dim i As Long　　'　　ループ用
　　Dim nFree As Integer　　'　　テキスト読み込み用空きナンバー

'　　sKey = "サル"
'　　sKey = "カエル"
　　sKey = "ネコ"
'　　sKey = "クマ"
'　　sKey = "カバ"

　　sCurDir = CurDir()
　　ChDir sFolPath
　　nFree = FreeFile

　　For i = Date To Date - 365 Step -1
　　　　sFile = Format(i, "yyyymmdd"".txt""")

　　　　If Dir(sFile) <> "" Then

　　　　　　Open sFile For Input As #nFree
　　　　　　sBuf = StrConv(InputB(LOF(nFree), #nFree), vbUnicode)
　　　　　　Close #nFree

　　　　　　arrS() = Split(sBuf, vbCrLf)　　'　　◆　改行文字、正しく指定
　　　　　　arrS() = Filter(arrS(), sKey, True)
'　　　　　　arrS() = Filter(arrS(), sKey, True, vbTextCompare)　　'　　←△　op.全角カナの徹底が怪しい場合

　　　　　　If UBound(arrS()) <> -1 Then
　　　　　　　　rtn = Split(Trim$(arrS(0)), "・")(0)
'　　　　　　　　rtn = Val(Trim$(arrS(0))) & "匹"　　'　　←△　op.区切り文字"・"の徹底が怪しい場合
　　　　　　　　Exit For
　　　　　　End If

　　　　End If
　　Next i

　　If IsEmpty(rtn) Then
　　　　MsgBox "notfound"
　　Else
　　　　With Sheets("Sheet1")　　'　　◆　シート名、正しく指定
　　　　　　.Cells(1, 1) = rtn　　'　　A1　に　"何匹？"
'　　　　　　.Cells(1, 2) = sKey　　'　　△　B1　に　"どの動物？"
'　　　　　　.Cells(1, 3) = sFile　　'　　△　C1　に　"いつ？"
　　　　End With
　　End If

　　ChDir sCurDir
End Sub