VBAについて質問です。

今回正規表現で抜き取りたいと考えているデータはヤフオクでお客様へ落札後に定型文を送るのですが、
その定型で返信されて来たデータを正規表現で抜き取りたいと考えています。

今回テストでお客様へ送ったメールは以下になります。



この度は商品の落札真にありがとうございます。
お手数をおかけしますが以下情報の記載をよろしくお願いします。

＜＜　コピーして貼り付けてください　＞＞
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

★郵便番号：
★住所：
★氏名：
★連絡先：

↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑


取引終了までどうぞよろしくお願いいたします。

お客様から帰ってきたメールです。（テスト）


いかが私の住所などになります。

＜＜　コピーして貼り付けてください　＞＞
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

★郵便番号：１１１－１１１１
★住所：あいうえおかきくけこ
★氏名：テスト
★連絡先：００００－００００

↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑


取引終了までどうぞよろしくお願いいたします。

そしてお客様情報が入っているメール部分のhtmlコードは以下になります。

<small>いかが私の住所などになります。<br><br>＜＜　コピーして貼り付けてください　＞＞<br>↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓<br><br>★郵便番号：１１１－１１１１<br>★住所：あいうえおかきくけこ<br>★氏名：テスト<br>★連絡先：００００－００００<br><br>↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑<br><br><br>取引終了までどうぞよろしくお願いいたします。<br><br>テスト</small></span></td>

作成中のコードは以下になっており、正規表現で情報を取得後、次から次へとお客様の情報をセルに保存したいと考えています。


Sub Macro()

Const BASE_URL As String = "http://{0}.auctions.yahoo.co.jp/show/contact_detail?aID={1}&target={2}&no=3&.crumb={3}"

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True

Range("A1").Select
Do Until ActiveCell.Value = ""
Dim url As String
url = Replace(BASE_URL, "{0}", "page9") 'page9とかpage1とか
url = Replace(url, "{1}", ActiveCell.Value)
url = Replace(url, "{2}", ActiveCell.Offset(0, 1).Value)
url = Replace(url, "{3}", ActiveCell.Offset(0, 2).Value)
ActiveCell.Offset(1, 0).Activate
objIE.Navigate2 url
While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True
Sleep 200
Wend

Loop

Myhtml = objIE.Document.Body.innerHTML

★この次に取得したhtmlを元に正規表現したいと考えています。

例えば、A1に商品ID、B1にヤフーID、そしてC1にURLに接続するために必要なcrumb数字というのが入っているのですが（A、B、C列はあらかじめデータがすべて入力されている状態になっています。）、正規表現後にD1に郵便番号、E1に住所、F1に氏名、G1に連絡先を入れたいと考えています。

A,B,C列のデータが終わるまで、繰り返し処理を行いたいと考えています。


End Sub

例えば正規表現で郵便番号を抜き取る場合ですが、

<br><br>★郵便番号：１１１－１１１１<br>★住所：

★郵便番号：　と　<br>★住所：　の間にある値を抜き取って、それをエクセルのD列に保存するにはどのような方法がとれるでしょうか？

お手数をおかけしますが、詳しい方がおりましたら、定型をひとつ作っていただければと考えております。

私の過去回答からです。
http://q.hatena.ne.jp/1256450972#a960810

シンプルな例ですから、正規表現を使う基本部分は理解できるものと思います。


もう解決した件ではありますが・・・
以前にもお話させていただいかもしれないのですが Debug.Printなどは一箇所ではなく
Debug.Print "開始"
url = Replace(BASE_URL, "{0}", "page9") 'page9とかpage1とか
Debug.Print url
url = Replace(url, "{1}", ActiveCell.Value)
Debug.Print url
url = Replace(url, "{2}", ActiveCell.Offset(0, 1).Value)
Debug.Print url
url = Replace(url, "{3}", ActiveCell.Offset(0, 2).Value)
Debug.Print url
Debug.Print "終了"
くらいのことはしたほうが良いです。
その時は面倒でも、短時間で自力解決できるようになりますし、
慣れている人でも、はまった時には、同様に細かなチェックポイントを入れますので、
ぜひとも、細かなチェックをするようになってください。

kn1967 さん

ご回答ありがとうございます。

Debug.Print 勉強になります。PHPでいう echo や　print_r みたいなものですね＾＾。

ちゃんと使いこなせるようになりたいと思います。

正規表現ですが

//変数の定義

Dim yuubin As String
Dim address As String
Dim name As String
Dim renraku As String

Dim d As Range
Dim e As Range
Dim f As Range
Dim g As Range

WITH　Myhtml


//正規表現

Set yuubin=　.Pattern = "\★郵便番号：(.+?)\<br>★住所": '検索パターン
Set address=　.Pattern = "\★住所：(.+?)\<br>★氏名": '検索パターン
Set name=　.Pattern = "\★氏名：(.+?)\<br>★連絡先：": '検索パターン
Set renraku=　.Pattern = "\★連絡先：(.+?)\<br><br><br>↑↑↑": '検索パターン

.IgnoreCase = True: '大文字と小文字は区別しない事とする
.Global = True: '文字列全体を対象とする

//入力した値をセルに入力する

d.Offset(0, 3) = yuubin
e.Offset(0, 4) = address
f.Offset(0, 5) = name
g.Offset(0, 6) = renraku

End With

こういった感じはありでしょうか。実行してみましたが、もちろん実行は出来ませんでした。。。

しかし、流れ的にはこういう風に持っていけたらと思います。。

.Pattern は１度に１つだけ、検索したいパターンが４つなら、
1つ目のパターンを指定→検索→２つ目のパターンを指定→検索・・・
ということを繰り返す事になる。

ただし、今回の場合は検索対象が１つのテキストなので、
一度に４つの項目を取得できるような検索パターンを作って、
SubMatchesでそれぞれを取得すれば良いだけの話。

・・・回答欄に投稿すべきかどうか悩むところなのだが、
自力解決して欲しいと望むので、ひとまず、本日はここまで。
（後日、見るかどうかは判らないし、他の人が回答いれるかもしれないので、
あまり、期待なさらぬよう願います。）

aiomockさん

Myhtml = objIE.Document.Body.innerHTML
Dim a As String

※以下のように直せば、正常に動作すると思います。
Set a = HTML_抽出処理(str変換HTML, "★郵便番号：(.*?)")
　　　　　　↓
Set a = HTML_抽出処理(Myhtml , "★郵便番号：(.*?)")

iccrh1　さん　と　kn1967　さん　のアドバイスを元に作ってみました。
htmlソースを呼び込んでからの流れです。

Dim MyHtml As Variant

MyHtml = objIE.Document.body.innerHTML

Dim re As Object
Dim mc As Object
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "★郵便番号：(.*?)<br>"
Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(1, "D").Value = mc(0).SubMatches(0)

MsgBox Range("D1").Value

D1にどうしても郵便番号が出力されないといけないはずなのですが、出力されません。。

Microsoft VBScript Regular Expression 5.5にチェックを入れてますし、正規表現設定も多分間違えていないはずです。今回は文字が入っていればちゃんとD列に出力するように命令しました。

このコードであればどこが間違えているでしょうか

わかる方おりましたらよろしくお願いいたします。

mc(0).SubMatches(0) をセルにいれてから、
セルの内容をDebug.Printしたのでは、
どこでおかしいのか判断つけらんないでしょ？

何箇所もDebug.Print入れてみるように書いたのは、ほんの少し前の話なのだが・・・

苦言だけだと何だから・・・一応、書いておくけど、
Cellsのパラメータは行と列を示す「数値」だからね。じゃ )/~~~

Kn1967さん

ご回答ありがとうございます。そしてお手数おかけします。
デバッグを入れてみました。

Dim MyHtml As Variant
Debug.Print "開始"
MyHtml = objIE.Document.body.innerHTML
Debug.Print MyHtml

Dim re As Object
Debug.Print re
Dim mc As Object
Debug.Print mc
Set re = CreateObject("VBScript.RegExp")
Debug.Print re
re.Pattern = "★郵便番号：(.*?)<br>"
Debug.Print re.Pattern
Set mc = re.Execute(MyHtml)
Debug.Print mc(0)
If mc.Count >= 1 Then Cells(1, "D").Value = mc(0).SubMatches(0)

しかし、実行すると

Debug.Print MyHtml　までは正しく表示してくれるのですが、それ以降のデータが

ブジェクトは、このプロパティまたはメソッドをサポートしていません。

というエラーが発生して値を返してくれません。

コードに問題があるとは思うのですが、どこが問題かが今一よくわからない状況です。
詳しい方おりましたら見ていただければと考えています。
よろしくお願いいたします。

＞Cellsのパラメータは行と列を示す「数値」
これは長年Excel使ってきて始めて確認したのだけど
　　Cells(1, "D").Value = 1
といった記述でも正しく D1 に書き込めた・・・間違った情報で申し訳ない。

お詫びという訳でもないけど、少しだけ書き置いて眠ることにしました。
まずDim は変数の宣言だけなのでDebug.Printはいらない。
re と re.Pattern はDebug.Printでは当該のエラーとなるだけなので、これも不要。

今回必要だった確認点は下記の３点。
（１）正しく取得できているかの確認
Debug.Print MyHtml
（２）正しく抜きだせているかの確認
Debug.Print mc(0)ではなく
Debug.Print mc(0).SubMatches(0)
（３）正しくセルに書き込めているかの確認
Debug.Print Range("D1").Value


さらに、私も少し動作確認用のコードを書いてみた。

' 私はデータ取得環境をもってないのでコメントされていたものを変数に直接代入。
Dim MyHtml As String
MyHtml = "<small>いかが私の住所などになります。<br>　中略　　</td>"

' 宣言の三行はそのまま
Dim re As Object
Dim mc As Object
Set re = CreateObject("VBScript.RegExp")

' ４回も同じ所作を繰り返すのは面倒なので、一発で取得するように変更
' 未指定のパラメータもセット
re.Pattern = "★(.*?)：(.*?)<br>"
re.IgnoreCase = True: '大文字と小文字は区別しない事とする
re.Global = True: '文字列全体を対象とする

' 取得
Set mc = re.Execute(MyHtml)

' 取得した中身をすべてDebug.Print
For Each mc2 In mc
Debug.Print mc2.SubMatches(0), mc2.SubMatches(1)
Next

上記が確認できたら、
'Debug.Printの３行を消して下記のような感じでセルに書き出す。
If mc.Count >=1 Then
Cells(1,"D").value = mc(0).SubMatches(1)
Cells(1,"E").value = mc(1).SubMatches(1)
Cells(1,"F").value = mc(2).SubMatches(1)
Cells(1,"G").value = mc(3).SubMatches(1)
End If

aiomockさん　
基本的には下記の内容で良いですが、Debug.Print で表示できない変数（オブジェクト）がエラーになります。

---------------------------------------
Dim MyHtml As Variant
Debug.Print "開始"
MyHtml = objIE.Document.body.innerHTML
Debug.Print MyHtml

Dim re As Object
Debug.Print re ………………エラーになる（削除してください）
Dim mc As Object
Debug.Print mc ………………エラーになる（削除してください）
Set re = CreateObject("VBScript.RegExp")
Debug.Print re ………………エラーになる（削除してください）
re.Pattern = "★郵便番号：(.*?)<br>"
Debug.Print re.Pattern
Set mc = re.Execute(MyHtml)
Debug.Print mc(0)
If mc.Count >= 1 Then Cells(1, "D").Value = mc(0).SubMatches(0)
---------------------------------------
また、特に問題はないのですが
Microsoft VBScript Regular Expression 5.5にチェック入れているのなら、

Set re = CreateObject("VBScript.RegExp")
　　　　　　　↓
Set re = New RegExp
で良いです。
※CreateObject("VBScript.RegExp")なら「Expression 5.5」のチェックは必要ありません。

以上の対応で、私は正常に動作しました。

正規表現で抜き出しでとまどっているみたいですが、別の角度から一言。
実は、元のデータ
>そしてお客様情報が入っているメール部分のhtmlコードは以下になります。
><small>いかが私の住所などになります。<br><br>＜＜　コピーして貼り付けてください　
>＞＞<br>↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓<br><br>★郵便番号：１１１－１１１１<br>★住所：あいうえおかきくけこ<br>★氏名：テスト<br>★連絡先：００００－００００<br><br>↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑<br><br><br>取引終了までどうぞよろしくお願いいたします。<br><br>テスト</small></span></td>
>
↑と思いこんでますが、実は、
objIE.Document.body.innerHTML で 取り出すと、
.innerHTML が 親切に、<br>とかを<BR>に変えている場合があるので、注意が必要かなぁ。

百聞は一見に～ http://d.hatena.ne.jp/ken3memo/20091212/1260570843 に画像貼っておきました。
何かの参考となれば、幸いです。(別角度からの参考意見でした、間違っていたらスミマセン。)

ゴメンなさい。kn1967さんとjccrh1さんの設定で、
re.IgnoreCase = True: '大文字と小文字は区別しない事とする
となってますね。スミマセン忘れてください。
※混乱させてスミマセン。

ご回答頂き本当にありがとうございます。アドバイスを参考に再度作成してみました。
自分のやりやすいスタイルで少し長くなってしまいましたが、コーディングしてみました。
後一歩で完成まで来ています。

Sub Macro()

Const BASE_URL As String = "http://{0}.auctions.yahoo.co.jp/show/contact_detail?aID={1}&target={2}&no=4&.crumb={3}"

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True

Range("A1").Select
Do Until ActiveCell.Value = ""

Dim url As String
url = Replace(BASE_URL, "{0}", "page9") 'page9とかpage1とか
url = Replace(url, "{1}", ActiveCell.Value)
url = Replace(url, "{2}", ActiveCell.Offset(0, 1).Value)
url = Replace(url, "{3}", ActiveCell.Offset(0, 2).Value)
ActiveCell.Offset(1, 0).Activate
objIE.Navigate2 url
While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True
Sleep 200
Wend

Dim MyHtml As Variant
Debug.Print "開始"
MyHtml = objIE.Document.body.innerHTML

Dim re As Object
Dim mc As Object
Dim i As Long
Dim LastRow As Long

Set re = New RegExp

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To LastRow

re.Pattern = "★郵便番号：(.*?)<br>"
re.IgnoreCase = True: '大文字と小文字は区別しない事とする
re.Global = True: '文字列全体を対象とする

Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(i, "D").Value = mc(0).SubMatches(0)

re.Pattern = "★住所：(.*?)<br>"
Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(i, "E").Value = mc(0).SubMatches(0)


re.Pattern = "★氏名：(.*?)<br>"
Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(i, "F").Value = mc(0).SubMatches(0)


re.Pattern = "★連絡先：(.*?)<br>"
Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(i, "G").Value = mc(0).SubMatches(0)


Next i

Loop

End Sub



後、一歩の所ですが、このプログラムを実行するとセルD、E、F、Gに一番最後に開いたお客様の情報がすべての列に入るようになっており、このエラーさえ克服できればこのプログラムは完成になります。

大変お手数をおかけしますが、時間があるかたで見ていただける方おりましたら一度見ていただければと思います。

自分でも今一度考えてみたいと思っております。

今回ご回答頂いた方本当にありがとうございます。

ご回答ありがとうございます。
皆さんの回答のおかげでプログラムが完成しました。
本当に感謝です＾＾。

Sub Macro()

Const BASE_URL As String = "http://{0}.auctions.yahoo.co.jp/show/contact_detail?aID={1}&target={2}&no=4&.crumb={3}"

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True

Range("A1").Select
Do Until ActiveCell.Value = ""

Dim url As String
url = Replace(BASE_URL, "{0}", "page9") 'page9とかpage1とか
url = Replace(url, "{1}", ActiveCell.Value)
url = Replace(url, "{2}", ActiveCell.Offset(0, 1).Value)
url = Replace(url, "{3}", ActiveCell.Offset(0, 2).Value)
ActiveCell.Offset(1, 0).Activate
objIE.Navigate2 url
While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True
Sleep 200
Wend

Dim MyHtml As Variant
Debug.Print "開始"
MyHtml = objIE.Document.body.innerHTML

Dim re As Object
Dim mc As Object
Dim i As Variant

Set re = New RegExp

i = ActiveCell.Row

re.Pattern = "★郵便番号：(.*?)<br>"
re.IgnoreCase = True: '大文字と小文字は区別しない事とする
re.Global = True: '文字列全体を対象とする

Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(i - 1, "D").Value = mc(0).SubMatches(0)

re.Pattern = "★住所：(.*?)<br>"
Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(i - 1, "E").Value = mc(0).SubMatches(0)


re.Pattern = "★氏名：(.*?)<br>"
Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(i - 1, "F").Value = mc(0).SubMatches(0)


re.Pattern = "★連絡先：(.*?)<br>"
Set mc = re.Execute(MyHtml)
If mc.Count >= 1 Then Cells(i - 1, "G").Value = mc(0).SubMatches(0)




Loop



End Sub

おめでとう。

以下、蛇足
参照設定による事前バインディングのほうがコーディングが楽になるし、
動作コスト的にも良かったりするんだけど、
パソコンを入れ替えた時などに「動かない！」って事で、
長時間悩んだりしちゃったりするので、
　　Set re = New RegExp
ではなく
　　Set re = CreateObject("VBScript.RegExp")
のほうを書いてたりする。

将来性を考えれば両方使えるに越したことはないのだけど、
事前バインディングを使うなら、マクロの先頭にでも
「このマクロを使う場合は参照設定で
　Microsoft VBScript Regular Expression 5.5にチェックをいれておく事！」
くらいのコメントを目立つように書いておく事をお勧めしておきます。

あと、今回程度のものならば特に問題にならないと思うのだけど、
オブジェクトを使い終わったら、
　　Set re = Nothing
といった具合に開放しておく癖をつけておいたほうが良いでしょう。

では、これにて本当に失礼。

ありがとうございます。

今回突破口を見つけ出せたのは　kn1967さん　と　jccrh1 のおかげです。

本当に感謝します。

また色々勉強になることを教えていただいてありがとうございます。

これからのプログラムにまた役立てたいと思います＾＾。