該当文字列を含む行抽出

英文の文書ファイルがあります。
この中に特定の文字列（例えば、「this is」)を含む行を抽出し、
リストしたいのです。

例えば、以下のような文書です。

this is a book
is that a desk no this is a box
yes this is a pen
that is a glove

その結果が、以下のように。

this is a book
is that a desk no this is a box
yes this is a pen

どのような命令を使えば宜しいのでしょうか。
調べたら「find」が見つかりましたが、検索元がセルとのことで、違うのかと。
「instr」は一文字のみの出現位置とか。
上手い具合の命令が見つかりませんでした。

文書を頭からセルに入れて「find」を使えばいいのかも知れませんが、
直接調べられれば（検索できれば）と思います。

宜しくお願いします。

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2015/08/30 18:23

こんにちは。

一般的には、テキストファイルは、Unix系 の　Grepというツールで処理されるものです。それを特化したものが、KWIC と言います。(KWIC Finderは、同種ですが、シェアウェアです)

http://www.tanomura.com/research/KWIC/

このKWIC は、大学を中心として、出ているフリーのツールですが、あえて、VBA等で作るまでには及ばないような気がしています。私自身は、特殊なgrep を、Excelに組み合わせて使っていますが、何百というテキストファイルの中から該当行を探すようなことをしています。最後はExcelが立ち上がります。

あえて、マクロということですと、今、ざっと作ってみましたが、このようなものになります。細かい検証をなされていませんが、現在は、 '検索文字　の下の、="this is" の所に文字を入れれば良いようになっています。

試してみた文章は以下の所で、検索文字 ="this"
http://learningenglish.voanews.com/content/are-y …

結果は、このようになります。
This is because the word smart has many meanings.
This means they have spent many years in school.
This definition of smart can also be used as a verb.
And this leads to the term “Smart Aleck".

フォームボタンなどに、このマクロを設置すると良いと思います。最初に、ファイルオープンダイアログが開きますので、それで、ファイルを選択します。複数ファイルを選ぶことが可能です。出力は、アクティブシートの2行目から、ファイル名が最初に貼り付けられ、その後、検索行が、一行ではなく、ピリオドを単位として出てきます。この点が、KWICやGrepとは違う点です。

なお、本日、集中度0に近く最悪のコンディションで、ほとんど、考えてコードは書かれていません。ミスがあるかもしれません。もし問題がありましたら、明日にでもお返事ください。


'//
Sub FindWordinText()
　Dim Fnames As Variant
　Dim fn As Variant
　Dim FNo As Integer
　Dim TextLine As String
　Dim arTxt, n, m, arbuf
　Dim i As Long
　Dim strFND As String
　Dim qt As String
　qt = Chr(34)
　'検索文字
　strFND = "this is"
　strFND = Replace(strFND, Space(1), Space(1), , , vbBinaryCompare)
　'出力の最初の行
　j = 2
　
　Fnames = Application.GetOpenFilename(FileFilter:="テキスト(*.txt),*.txt", MultiSelect:=True)
　If VarType(Fnames) = vbBoolean Then Exit Sub
　For Each fn In Fnames
　　FNo = FreeFile()
　　Open fn For Input As #FNo
　　Do While Not EOF(FNo)
　　　Line Input #FNo, TextLine
　　　If InStr(1, TextLine, strFND, 1) > 0 Then
　　　　buf = buf & vbCrLf & TextLine
　　　End If
　　Loop
　　Close #FNo
　　arTxt = Split(buf, vbCrLf)
　　Cells(j, 1).Value = "*" & Dir(fn)
　　j = j + 1
　　For Each n In arTxt
　　　If Trim(n) <> "" Then
　　　　If InStr(1, n, "." & qt, 1) > 0 Then
　　　　　'dot in quotations
　　　　　n = Replace(n, "." & qt, "#.", , 1, 1)
　　　　End If
　　　　If InStr(1, n, ".") > 0 Then
　　　　　arbuf = Split(n, ".")
　　　　　For Each m In arbuf
　　　　　　If InStr(1, m, strFND, 1) > 0 Then
　　　　　　　'retrieve quotation mark
　　　　　　　m = Replace(m, "#", qt, , 1, 1)
　　　　　　　Cells(j, 1).Value = Trim(m) & "."
　　　　　　　j = j + 1
　　　　　　End If
　　　　　Next m
　　　　　Erase arbuf
　　　　Else
　　　　　Cells(j, 1).Value = Trim(n)
　　　　　j = j + 1
　　　　End If
　　　End If
　　　buf = ""
　　Next n
　　j = j + 1
　Next fn
End Sub

この回答へのお礼

早速有り難うございました。
色々ご親切にお教えいただき、恐縮です。

やはり簡単にfindのようにはいかないのですね、
驚きました。
こんなに複雑なプログラムが簡単に書けるなど、驚きです。

取り敢えずコピーさせていただきやってみましたが、
完璧です。
一つずつ解析するのが大変そうですが。
とにかくやりたいことは満足しましたので使わせていただきます。

お疲れのところお世話になりました。

お礼日時：2015/08/30 20:05