VBAについて質問です。


VBAで正規表現を行いたいのですがやり方がわからず困惑しております。

html情報を取得する所まではできるのですが、

取得後に、例えば以下のような関数みたいなことはできないでしょうか?

関数(Myhtml(取得したhtmlデータ),正規表現の条件,取得したデータの保存先)

また、情報を取得した後に、指定したエクセルのセルにデータを記入するという所も少しわからず困惑しております。

大変お手数をおかけしますが、わかるかたおりましたらご回答いただければと考えております。

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

回答の条件
  • 1人2回まで
  • 登録:2009/12/11 19:21:41
  • 終了:2009/12/12 11:54:49

ベストアンサー

id:jccrh1 No.3

jccrh1回答回数111ベストアンサー獲得回数192009/12/11 22:27:02

ポイント100pt

すみません、下のコメントを見ていませんでしたので、再度回答させて頂きます。

郵便番号、住所、氏名、連絡先を取得できるように修正してみました。

【メイン】
  郵便番号 = HTML_抽出処理(str変換HTML, "★郵便番号:(.*?)<br>")
  住所 = HTML_抽出処理(str変換HTML, "★住所:(.*?)<br>")
  氏名 = HTML_抽出処理(str変換HTML, "★氏名:(.*?)<br>")
  連絡先 = HTML_抽出処理(str変換HTML, "★連絡先:(.*?)<br>")
【関数】
Function HTML_抽出処理(strHTML As String, 正規条件 As String)
  Dim re     As Object
  Dim mc     As Object
  Set re = CreateObject("VBScript.RegExp")
  HTML_抽出処理 = ""
  re.Pattern = 正規条件
  Set mc = re.Execute(strHTML)
  If mc.Count >= 1 Then HTML_抽出処理 = mc(0).SubMatches(0)
End Function
id:aiomock

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

標準モジュールに関数を設定させていただきました。

また、コードを






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

Dim a As String

Set a = HTML_抽出処理(str変換HTML, "★郵便番号:(.*?)
")

Debug.Print a

End Sub








のようにして試してみたのですが、

定数が定義されていません。というエラーが表示されてしまいます。

str変換HTML を定義しないといけないみたいですが、定義とは

Dim str変換HTML as string

のようにすればいいのでしょうか?

ここをきちんと定義出来れば、関数が起動して正規表現をしてくれるのではないかと考えているのですが。。。

初心者すぎて申し訳ありません。。。

2009/12/11 23:20:04

その他の回答(2件)

id:van-dine No.1

van-dine回答回数108ベストアンサー獲得回数112009/12/11 21:51:59

ポイント50pt

正規表現を使うには次の設定が必要です。

  1. [Alt]+[F11]でVBAの編集画面を開く
  2. ツール(T)→参照設定(R)を選ぶ
  3. Microsoft VBScript Regular Expression 5.5にチェックを入れる

使い方としては、

Set RE = New RegExp

でインスタンスを作成し、利用するというもの。

たとえば、

Dim url0 As RegExp
url0.IgnoreCase = False '大文字・小文字の同一視
url0.Global = False '全部検索するか
url0.Pattern = "\{0\}" 'パターン。正規表現的におかしかったので修正しました
'中略
url = url1.Replace(BASE_URL, "page9") 'page9とかpage1とか

のように使います。

詳しい用法は下のページをご覧ください。

http://msdn.microsoft.com/ja-jp/library/cc392484.aspx

id:aiomock

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

Set RE = New RegExp

 

のインスタンスを作成し、これから正規表現を始めます のような宣言みたいなのが必要ということですね^^。

設定したいと思います。←間違えていたらご指摘お願いします。

2009/12/11 22:28:25
id:jccrh1 No.2

jccrh1回答回数111ベストアンサー獲得回数192009/12/11 22:05:16

ポイント100pt

html情報から何を取得したいのか分かりませんが、一応作成してみました。

【メイン】
 Call HTML_抽出処理(str変換HTML, "<TR.*?>((.|\n)*?)</TR>", "D:\抽出データ.txt")
【サブ】
Sub HTML_抽出処理(strHTML As String, 正規条件 As String, 保存ファイル名 As String)
  Dim I      As Long
  Dim re     As Object
  Dim mc     As Object
  Set re = CreateObject("VBScript.RegExp")
  re.MultiLine = True
  re.Global = True
  re.IgnoreCase = True
  re.Pattern = 正規条件
  Set mc = re.Execute(strHTML)
  Open 保存ファイル名 For Output As #1
  For I = 0 To mc.Count - 1
   Print #1, mc(I)
  Next I
  Close #1
End Sub

追加事項
1.Print #1, mc(I).SubMatches(0) にすれば xxxxx が出力できます。 
   <TR~>xxxxx</TR>の時
2.セルへの設定
  Print #1, mc(I)の所を
  Range("A2").Offset(I) = mc(I)
    でできると思います。
  但し、文字数が多い場合はエラーになることもあります。
id:aiomock

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

2009/12/11 22:24:09
id:jccrh1 No.3

jccrh1回答回数111ベストアンサー獲得回数192009/12/11 22:27:02ここでベストアンサー

ポイント100pt

すみません、下のコメントを見ていませんでしたので、再度回答させて頂きます。

郵便番号、住所、氏名、連絡先を取得できるように修正してみました。

【メイン】
  郵便番号 = HTML_抽出処理(str変換HTML, "★郵便番号:(.*?)<br>")
  住所 = HTML_抽出処理(str変換HTML, "★住所:(.*?)<br>")
  氏名 = HTML_抽出処理(str変換HTML, "★氏名:(.*?)<br>")
  連絡先 = HTML_抽出処理(str変換HTML, "★連絡先:(.*?)<br>")
【関数】
Function HTML_抽出処理(strHTML As String, 正規条件 As String)
  Dim re     As Object
  Dim mc     As Object
  Set re = CreateObject("VBScript.RegExp")
  HTML_抽出処理 = ""
  re.Pattern = 正規条件
  Set mc = re.Execute(strHTML)
  If mc.Count >= 1 Then HTML_抽出処理 = mc(0).SubMatches(0)
End Function
id:aiomock

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

標準モジュールに関数を設定させていただきました。

また、コードを






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

Dim a As String

Set a = HTML_抽出処理(str変換HTML, "★郵便番号:(.*?)
")

Debug.Print a

End Sub








のようにして試してみたのですが、

定数が定義されていません。というエラーが表示されてしまいます。

str変換HTML を定義しないといけないみたいですが、定義とは

Dim str変換HTML as string

のようにすればいいのでしょうか?

ここをきちんと定義出来れば、関数が起動して正規表現をしてくれるのではないかと考えているのですが。。。

初心者すぎて申し訳ありません。。。

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

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



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

    << コピーして貼り付けてください >>
    ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

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

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


    取引終了までどうぞよろしくお願いいたします。
  • id:aiomock
    お客様から帰ってきたメールです。(テスト)


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

    << コピーして貼り付けてください >>
    ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

    ★郵便番号:111-1111
    ★住所:あいうえおかきくけこ
    ★氏名:テスト
    ★連絡先:0000-0000

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


    取引終了までどうぞよろしくお願いいたします。
  • id:aiomock
    そしてお客様情報が入っているメール部分のhtmlコードは以下になります。

    <small>いかが私の住所などになります。<br><br><< コピーして貼り付けてください >><br>↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓<br><br>★郵便番号:111-1111<br>★住所:あいうえおかきくけこ<br>★氏名:テスト<br>★連絡先:0000-0000<br><br>↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑<br><br><br>取引終了までどうぞよろしくお願いいたします。<br><br>テスト</small></span></td>
  • id:aiomock
    作成中のコードは以下になっており、正規表現で情報を取得後、次から次へとお客様の情報をセルに保存したいと考えています。


    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

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

    <br><br>★郵便番号:111-1111<br>★住所:

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

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

  • id:kn1967
    私の過去回答からです。
    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 "終了"
    くらいのことはしたほうが良いです。
    その時は面倒でも、短時間で自力解決できるようになりますし、
    慣れている人でも、はまった時には、同様に細かなチェックポイントを入れますので、
    ぜひとも、細かなチェックをするようになってください。
  • id:aiomock
    kn1967 さん

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

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

    ちゃんと使いこなせるようになりたいと思います。
  • id:aiomock
    正規表現ですが

    //変数の定義

    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

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

    しかし、流れ的にはこういう風に持っていけたらと思います。。
  • id:kn1967
    .Pattern は1度に1つだけ、検索したいパターンが4つなら、
    1つ目のパターンを指定→検索→2つ目のパターンを指定→検索・・・
    ということを繰り返す事になる。

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

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

  • id:jccrh1
    aiomockさん

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

    ※以下のように直せば、正常に動作すると思います。
    Set a = HTML_抽出処理(str変換HTML, "★郵便番号:(.*?)")
          ↓
    Set a = HTML_抽出処理(Myhtml , "★郵便番号:(.*?)")
  • id:aiomock
    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列に出力するように命令しました。

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

    わかる方おりましたらよろしくお願いいたします。
  • id:kn1967
    mc(0).SubMatches(0) をセルにいれてから、
    セルの内容をDebug.Printしたのでは、
    どこでおかしいのか判断つけらんないでしょ?

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

    苦言だけだと何だから・・・一応、書いておくけど、
    Cellsのパラメータは行と列を示す「数値」だからね。じゃ )/~~~
  • id:aiomock
    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 までは正しく表示してくれるのですが、それ以降のデータが

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

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

    コードに問題があるとは思うのですが、どこが問題かが今一よくわからない状況です。
    詳しい方おりましたら見ていただければと考えています。
    よろしくお願いいたします。
  • id:kn1967
    >Cellsのパラメータは行と列を示す「数値」
    これは長年Excel使ってきて始めて確認したのだけど
      Cells(1, "D").Value = 1
    といった記述でも正しく D1 に書き込めた・・・間違った情報で申し訳ない。

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

    今回必要だった確認点は下記の3点。
    (1)正しく取得できているかの確認
    Debug.Print MyHtml
    (2)正しく抜きだせているかの確認
    Debug.Print mc(0)ではなく
    Debug.Print mc(0).SubMatches(0)
    (3)正しくセルに書き込めているかの確認
    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")

    ' 4回も同じ所作を繰り返すのは面倒なので、一発で取得するように変更
    ' 未指定のパラメータもセット
    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の3行を消して下記のような感じでセルに書き出す。
    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
  • id:jccrh1
    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」のチェックは必要ありません。

    以上の対応で、私は正常に動作しました。
  • id:ken3memo
    正規表現で抜き出しでとまどっているみたいですが、別の角度から一言。
    実は、元のデータ
    >そしてお客様情報が入っているメール部分のhtmlコードは以下になります。
    ><small>いかが私の住所などになります。<br><br><< コピーして貼り付けてください 
    >>><br>↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓<br><br>★郵便番号:111-1111<br>★住所:あいうえおかきくけこ<br>★氏名:テスト<br>★連絡先:0000-0000<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 に画像貼っておきました。
    何かの参考となれば、幸いです。(別角度からの参考意見でした、間違っていたらスミマセン。)

  • id:ken3memo
    ゴメンなさい。kn1967さんとjccrh1さんの設定で、
    re.IgnoreCase = True: '大文字と小文字は区別しない事とする
    となってますね。スミマセン忘れてください。
    ※混乱させてスミマセン。
  • id:aiomock
    ご回答頂き本当にありがとうございます。アドバイスを参考に再度作成してみました。
    自分のやりやすいスタイルで少し長くなってしまいましたが、コーディングしてみました。
    後一歩で完成まで来ています。

    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に一番最後に開いたお客様の情報がすべての列に入るようになっており、このエラーさえ克服できればこのプログラムは完成になります。

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

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

    今回ご回答頂いた方本当にありがとうございます。
  • id:aiomock
    ご回答ありがとうございます。
    皆さんの回答のおかげでプログラムが完成しました。
    本当に感謝です^^。

    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
  • id:kn1967
    おめでとう。

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

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

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

    では、これにて本当に失礼。
  • id:aiomock
    ありがとうございます。

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

    本当に感謝します。

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

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

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません