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

質問

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

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

お礼

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

回答No.3

KURUMITO

A1にデータがあるとしてB1セルに文字列を表示させるとしたら例えば次のようなマクロになりますね。

Range("B1").Formula="=IF(A1="","",MID(A1,FIND("mail",A1)+4,FIND("@",A1)-FIND("mail",A1)-4))"

回答No.2

imogasi

エクセル関数でやると
例データ　A1:A3
On 2009/07/07, at 1:5, mail*****@docomo.ne.jp wrote:
On 2009/7/7, at 21:56, mail*****@docomo2.ne.jp wrote:
関数　B2
=MID(A2,FIND("mail",A2),FIND("jp",A2)+2-FIND("mail",A2))
B3は式複写
結果
mail*****@docomo.ne.jp
mail*****@docomo2.ne.jp
ーー
VBAではFindに当たるのは、Instr関数だから
Sub test01()
For i = 2 To 3
x = Cells(i, "A")
s = Mid(x, InStr(x, "mail"), InStr(x, "jp") + 2 - InStr(x, "mail"))
MsgBox s
Next i
End Sub
ｓに答えの文字列が出る。
上記はエクセルのシートにデータが整った場合の話だが、実は他ソフトとの連携で旨くやれるプログラム力のレベルなのかな。
そちらの方が格段に難しいと思うが。

回答No.1

keithin

せめてその「メールのやりとり」を，どんな格好でエクセルに取り込みたい/取り込めるのか，前段の部分が無いとマクロにするにもとっかかりが無さ過ぎです。

作業例：
sub macro1()
　dim myPath as string
　dim fs as string
　dim s as string
　dim h as range
　set h = activesheet.range("A1")
　myPath = "c:\test\"

　fs = dir(mypath & "*.txt")
　do until fs = ""
　　open mypath & fs for input as #1
　　do until eof(1)
　　　line input #1, s
　　　if trim(s) like "On*wrote:" then
　　　　h = s
　　　　set h = h.offset(1)
　　　end if
　　loop
　　close #1
　　fs = dir()
　loop
end sub

お礼

ありがとうございます。
説明が足りなくて申し訳ありませんでした。