複数ファイルから情報抽出

質問

VBAで、複数ファイルから、指定したセルに情報抽出したいと思っております。

下記のようなエクセルファイルがあり、1列目、２列目はすでに入力されています。
２列目に詳細が書かれているテキストファイル名が記載されていて、該当ファイルは、同じルートの \filefoldaの中に、格納されています。　\filefolda内のテキストファイルから、３列目の情報を抽出したいのです。

アメリカ　　　america.txt　 　　　　　　　 シカゴ　←テキストファイルから抽出　
日本　　　　japan-oamori1.txt　　　　　
ロシア　　　rossia.txt　　　　　　　　

テキストファイルの中身（アメリカの例）：

<div>
<div>
<h1>参加国</h1>

<div id="country">
<div id="organizationsBox">
<h1>アメリカ<br>　　　←この２行だけを取り出して、セルに入れたい。（３行の場合もある）
シカゴ</h1>　　　　←

<h2></h2>
<div>
<p>内容</p>
</div>
<h2>人数</h2>
<div></div>
<h2>メモ</h2>

やりたいこと：
\filefolda　内の各該当のファイル（1列目は「america.txtを」開いて、地域名（１行目は、「シカゴ」）をエクセルのセルに取り出したいが、一度には難しそうなので、まずは、
テキストファイルから、<h1>から、</h1>までの行を取り出して、エクセルのセルに入れていきたいと
考えております。
コードは作成してみたのですが、ＶＢＡ初心者でうまくいきません。どこをどう直したらよいのかご教授いただけると助かります。よろしくお願い致します。

Sub toridashi()

Dim InputFile As String
Dim FileName As String
Dim i As Integer
Dim LastRow As String

LastRow = Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To LastRow
FileName = Cells(i, 2).Value

InputFile = ActiveWorkbook.Path + "\filefolda\" + FileName
Open InputFile For Input As #1

Dim NameLineString As String
Dim st As Integer

st = 0

While Not (EOF(1))
Line Input #1, NameLineString

Select Case st
Case 0
　 If InStr(NameLineString, "<div id="country">") > 0 Then
　 st = 1
　 End If
Case 1
　 If InStr(NameLineString, "<h1>") > 0 Then
　 st = 2
　 End If
Case 2
　 If InStr(NameLineString, "<h2>") > 0 Then
　 st = 1
　 End If
End Select

　 If st = 2 Then
　 Cells(i, 3).Value = NameLineString
　 End If
　Wend
　Close #50
　Next i
End Sub

回答No.2

mitarashi

ご質問文の内容が目的テキストファイルの全てなら、一括で読み込んで、Instrで「アメリカ」を探し、「アメリカ」の場所を始点に「</h1>」を探し、Midで取り出せば十分と思いますが、もう少し汎用性のありそうな回答をしておきます。改行の存在により手こずってしまいました。
>３行の場合もある　
というのが、解釈に迷うところですが、<br>を介して、別の都市名がもう一つ入ると考えました。
ファイル一個分だけですが、ご参考まで。
Sub test()
Dim targetString As String, targetFileName As String
Dim regEX As Object
Dim MatchesDiv As Variant, MatchesH1 As Variant
Dim MatchDiv As Variant, MatchH1 As Variant
Dim buf As Variant
Dim i As Long

Set regEX = CreateObject("VBScript.RegExp")
With regEX
.ignorecase = True
.MultiLine = True
.Global = True
End With
targetFileName = "test.txt"
targetString = readTextFile(ActiveWorkbook.Path & "\" & targetFileName)
'最後に改行を削除しているので、初めから削除してしまった方が、検索パターンが簡単になりますが、折角試行錯誤したので、そのまま載せてあります。
regEX.Pattern = "<div id=""organizationsBox"">[\S\s\n\r]*?</div>"
Set MatchesDiv = regEX.Execute(targetString)
For Each MatchDiv In MatchesDiv
regEX.Pattern = "<h1>([\S\s\r\n]*?)</h1>"
Set MatchesH1 = regEX.Execute(MatchDiv)
For Each MatchH1 In MatchesH1
buf = Split(WorksheetFunction.Clean(MatchH1.submatches.Item(0)), "<br>")
For i = 0 To UBound(buf)
Debug.Print buf(i)
Next i
Next MatchH1
Set MatchesH1 = Nothing
Next MatchDiv
Set MatchesDiv = Nothing
Set regEX = Nothing
End Sub

'テキストファイルをひとまとめの文字列として読み込む
Private Function readTextFile(filename As String) As String
Dim FSO As Object

Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.getfile(filename).OpenAsTextStream
readTextFile = .ReadAll
.Close
End With
Set FSO = Nothing
End Function

参考URL
正規表現
http://officetanaka.net/excel/vba/tips/tips38.htm
こちらでFileSystemObjectの勉強すると、たいていのファイル処理ができます。
http://officetanaka.net/excel/vba/filesystemobject/textstream07.htm

回答No.1

cj_mover

こんにちは。

Line Input を使うと大変なので、
テキストファイルを一度に読み込む方法を紹介しておきます。

一応、指摘、
　文字列の連結は & 演算子を使います。
　+ 演算子は数値加算用として使い分けましょう。

> If InStr(NameLineString, "<div id="country">") > 0 Then
　ここは"<div id=""country"">")のように書きます。
　例えば　文"字"列　という値をコード上で扱う時は、
　"文""字""列"　というように文字列中の " を ふたつ重ねて "" にします。

ご提示のコードで目指す処理の方向性は理解できるのですが、
私には再現できませんでしたので、
テキストファイルを一度に読み込んだ全文に対して、
ひたすらテキスト処理をする内容に書き換えています。

例示のようなHTMLソース（？）などでは、
大文字であるか小文字であるか保証されていない、という前提で
コードを書くのが通例ですので、
テキスト処理を必要なだけ、TextCompareで書いています。
vbTextCompare を引数とした各関数のヘルプ等を確認しておいてください。

> <h1>アメリカ<br>
> シカゴ</h1>
は、
> <h1>アメリカ<br>シカゴ</h1>
と書かれていても、ソースの内容としては同じですから
どちらにも対応するよう書いてます。

テキストファイルの改行はCrLfでもLfでも対応するように書いてます。

テキストファイルの文字コードは、ANSI という前提で書いています。

エラー処理は対処が判らない部分は書いてません。
Ｂ列で指定されたファイルが存在しない、
抽出したい文字列が１行しかない、
等の場合、エラーで跳ねられます。

検索するタグが見つからない場合はMsgBoxを表示して次に進みます。

ソースの<br>と改行の間に空白等が有ったりすると、処理は不正に終わります。

２行めの「都市名？」をＣ列に出力したい、のは解りますが、
１行めの「国名？」を出力する先
が、示されていませんので暫定でＡ列に出力させています。
' ◆の行、を適宜修正してください。

> （３行の場合もある）
その場合、どうしたいのか、示されていません。
条件分岐だけ書いておきましたので
' ' ◆◆の行、をご自分で書き加えてください。

Colse #でいちいち閉じる代りに、テキストファイルを開きっ放しで、
最後の最後にResetで纏めて閉じています。

FreeFile()関数の使い方は非常に一般的なものです。覚えてください。

将来的には、正規表現やHTMLソース等の扱いも覚えられたら、もう少し楽に書けるようになります。

不足した情報を補うように書いていますから、そのまま動いたならラッキー。
補足あれば、追ってレスします。

Sub Re8254890()

Dim InputFile As String
Dim FolderPath As String　　' フォルダパス
Dim sBuf As String　　' テキスト読込用バッファ
Dim arrTemp　　' 改行区切りの配列変数
Dim LastRow As Long
Dim Pos1 As Long　　' 抽出先頭桁位置（最終的に"<h1>"の次の桁位置）
Dim Pos2 As Long　　' 抽出する文字列の次にくる桁位置（"</h1>"の先頭桁位置）
Dim i As Integer
Dim FreeNum As Integer　　' 使用可能なファイル番号

　　LastRow = Range("B" & Rows.Count).End(xlUp).Row
　' ' 繰り返す必要のないものはループの外に書く。
　　FolderPath = ActiveWorkbook.Path & "\filefolda\"

　　For i = 1 To LastRow

　　　　InputFile = FolderPath & Cells(i, 2).Value

　　　' ' 使用可能なファイル番号
　　　　FreeNum = FreeFile()
　　　' ' テキストファイルを開く
　　　　Open InputFile For Input As #FreeNum

　　　' ' LOF関数が返すファイルサイズ分のバイト数だけ全文を一気に
　　　' ' InputB$関数で読み込んで
　　　' ' StrConv関数で文字コードをUnicodeに直す。
　　　' ' →テキストファイルの全文をバッファsBufに格納
　　　　sBuf = StrConv(InputB$(LOF(FreeNum), #FreeNum), vbUnicode)

　　　' ' sBuf で "<div id=""country"">" に一致する桁位置（TextCompare）
　　　　Pos1 = InStr(1, sBuf, "<div id=""country"">", vbTextCompare)
　　　' ' 初期化
　　　　Pos2 = 0

　　　' ' "<div id=""country"">" が見つかっているならば
　　　　　' ' sBuf で "<div id=""country"">" より後ろで
　　　　　' ' "<h1>"に一致する桁位置（TextCompare）
　　　　If Pos1 > 0 Then _
　　　　　　Pos1 = InStr(Pos1, sBuf, "<h1>", vbTextCompare) + 4

　　　' ' " <div id=""country"">"と"<h1>" が見つかっているならば
　　　　　' ' sBuf で "<h1>"より後ろで
　　　　　' ' "</h1>"に一致する桁位置（TextCompare）
　　　　If Pos1 > 0 Then _
　　　　　　Pos2 = InStr(Pos1, sBuf, "</h1>", vbTextCompare)

　　　' ' 検索対象タグ すべて が見つかっているならば
　　　　If Pos2 > 0 Then

　　　　　' ' "<h1>" と "</h1>" に挟まれた文字列、に、sBUfを書き換え
　　　　　　sBuf = Mid$(sBuf, Pos1, Pos2 - Pos1)

　　　　　' ' ■処理し易いようにテキスト整形
　　　　　' ' sBuf に vbCrLf（改行） が見つかるならば）
　　　　　　　' ' sBuf の vbCrLf（改行） を vbLf（改行）に置換
　　　　　　If InStr(sBuf, vbCrLf) > 0 Then _
　　　　　　　　sBuf = Replace(sBuf, vbCrLf, vbLf)

　　　　　' ' sBuf に "<br>" & vbLf（改行） が見つかるならば（TextCompare）
　　　　　　　' ' sBuf の "<br>" & vbLf （TextCompare）を vbLfに置換
　　　　　　If InStr(1, sBuf, "<br>" & vbLf, vbTextCompare) > 0 Then _
　　　　　　　　sBuf = Replace(sBuf, "<br>" & vbLf, vbLf, , , vbTextCompare)

　　　　　' ' sBuf に （改行を省略した）"<br>"　が見つかるならば（TextCompare）
　　　　　　　' ' sBuf の "<br>" （TextCompare）を vbLfに置換
　　　　　　If InStr(1, sBuf, "<br>", vbTextCompare) > 0 Then _
　　　　　　　　sBuf = Replace(sBuf, "<br>", vbCrLf, , , vbTextCompare)
　　　　　' ' ■以上の処理で改行はvbLfに統一、"<br>"は削除済

　　　　　' ' Split関数でｓBufを改行vbLf区切りで配列としてarrTempに格納
　　　　　' ' １行めはarrTemp(0)、２行めはarrTemp(1)、３行めがあればarrTemp(2)
　　　　　　arrTemp = Split(sBuf, vbLf)

　　　　　' ' １行めの文字列＝arrTemp(0)　を、Trim$関数に掛けて、１列目に出力
　　　　　　Cells(i, "A").Value = Trim$(arrTemp(0))　　' ◆
　　　　　' ' ２行めの文字列＝arrTemp(1)　を、Trim$関数に掛けて、３列目に出力
　　　　　　Cells(i, "C").Value = Trim$(arrTemp(1))
　　　　　' ' 配列変数のサイズを確認して、３行以上ある場合（、の処理が必要なら）
　　　　　　If UBound(arrTemp) > 1 Then
　　　　　　　' ' ◆◆３行以上ある場合の処理
　　　　　　End If
　　　　Else
　　　　　　MsgBox "タグが見つかりません" & vbLf & InputFile
　　　　End If

　　Next i

　' ' Open ステートメントで開いたすべてのファイルをまとめて閉じる
　　Reset

End Sub