エクセルで特定文字列の抽出マクロを教えてください

質問

エクセルで以下のような文字列を抽出するマクロを教えてください。

On 2009/07/07, at 21:55, mail*****@docomo.ne.jp wrote:

メールのやり取りの本文内容から上記部分だけを抽出したいと考えています。
日時は変わりますが、他箇所は一緒です。

よろしくお願い致します。

回答No.4

Wendy02 · ベストアンサー

私自身も、通信ログは、Excelに貼りつけた状態からのものという前提からです。

'標準モジュールに登録して、FindText を実行してください。
シートがひとつ追加され、そこに出力されます。

Sub FindText()
　Dim rng As Range
　Dim c As Range, n As Variant
　Dim arbuf() As String, buf As String
　Dim i As Long, j As Long
　With ActiveSheet
　　On Error Resume Next
　　Set rng = .UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
　　On Error GoTo 0
　　For Each c In rng.Cells
　　　If InStr(1, c.Value, "docomo", 1) > 0 Then
　　　　buf = sbFind_wRE(c.Value)
　　　　If buf <> "" Then
　　　　　For Each n In Split(buf, "|", , 1)
　　　　　 If n <> "" Then
　　　　　　ReDim Preserve arbuf(i)
　　　　　　arbuf(i) = n
　　　　　　i = i + 1
　　　　　 End If
　　　　　Next n
　　　　End If
　　　End If
　　Next c
　End With
　With Worksheets.Add(After:=ActiveSheet) 'シートを追加
　　j = UBound(arbuf)
　　.Range("A1").Resize(j + 1, 1).Value = Application.Transpose(arbuf)
　End With
End Sub
Private Function sbFind_wRE(ByVal strTxt As String)
Dim ret As String
Dim Matches As Object
Dim Match As Object
With CreateObject("VBScript.RegExp")
　.Pattern = "On \d{4}/[01]\d/[0-3]\d, at [0-6]\d:[0-6]\d, [^@]+@[A-Za-z\.]+jp.? wrote:"
　.Global = True
　If .Test(strTxt) Then
　Set Matches = .Execute(strTxt)
　For Each Match In Matches
　　 ret = Match.Value & "|" & ret
　Next Match
　End If
End With
　If ret <> "" Then
　　sbFind_wRE = ret
　End If
End Function

お礼

ありがとうございました。