単勝（人気順） を探し、データをセットする
同様に、
を探し 表をコピーして、貼り付けます。
単純に探す文字を "単勝（人気順）"としただけですが、
Private Sub CommandButton1_Click()
Debug.Print Me.WebBrowser1.Document.URL
Debug.Print Me.WebBrowser1.Document.Title
'テーブル取り出しのテスト
Dim n As Integer
'表示完了後、THタグ 馬名を探す
Dim tagTH As Object 'THのタグを保存する
Dim nTHNo As Integer '見つけたオブジェクトの場所
Set tagTH = Me.WebBrowser1.Document.all.tags("TH") 'THのタグを取り出す
nTHNo = -1 'エラーの-1で初期化する
For n = 0 To tagTH.Length - 1 'THのタグを頭から探る
If tagTH(n).InnerText = "馬名" Then
nTHNo = n '見つけた番号をセットする。
Exit For '見つけたのでループを抜ける。
End If
Next n
'エラーの判断
If nTHNo = -1 Then '-1のまま、見つからなかったら、エラーにする。
MsgBox "馬名の表が見つかりません、システム管理者に連絡してください"
Exit Sub '関数を抜ける
End If
'見つけた場所 nTHNoから上のTABLEオブジェクトを探す
Dim objOYA_TAG As Object '親のオブジェクトを入れる
Set objOYA_TAG = tagTH(nTHNo).parentElement '見つけたTH馬名 その上.parentElementを代入
While objOYA_TAG.tagname <> "TABLE" 'タグの名前がTABLEになるまで(TABLE以外の間まわる)
Set objOYA_TAG = objOYA_TAG.parentElement 'さらに、一つ上の親タグを代入
Wend
'↑必ずTHの上にTABLEがあると仮定して、エラー処理はしてないけど・・・
'テーブルが見つかったので、コピーする。
Dim r As Object
Set r = Me.WebBrowser1.Document.body.createControlRange
r.Add objOYA_TAG '上で見つけたテーブルを指定する。
r.Select 'セレクト 選択
Me.WebBrowser1.ExecWB 12, 0 'コマンド発行 OLECMDID_COPY = 12 コピー
Set r = Nothing 'Rは用済み
'テスト用に新規のブックを追加する
Workbooks.Add '新規ブックを追加
'形式を選択して貼り付け HTML貼り付けのテスト
Sheets.Add 'テスト用のシートを新規追加する
ActiveSheet.Name = "HTML形式で貼り付け" 'シートに名前を付ける
Range("A1").Select
ActiveSheet.PasteSpecial Format:="HTML"
'単勝（人気順）
Set tagTH = Me.WebBrowser1.Document.all.tags("TH") 'THのタグを取り出す
nTHNo = -1 'エラーの-1で初期化する
For n = 0 To tagTH.Length - 1 'THのタグを頭から探る
If tagTH(n).InnerText = "単勝（人気順）" Then
nTHNo = n '見つけた番号をセットする。
Exit For '見つけたのでループを抜ける。
End If
Next n
'エラーの判断
If nTHNo = -1 Then '-1のまま、見つからなかったら、エラーにする。
MsgBox "単勝（人気順）の表が見つかりません、システム管理者に連絡してください"
Exit Sub '関数を抜ける
End If
'見つけた場所 nTHNoから上のTABLEオブジェクトを探す
Set objOYA_TAG = tagTH(nTHNo).parentElement '見つけたTH馬名 その上.parentElementを代入
While objOYA_TAG.tagname <> "TABLE" 'タグの名前がTABLEになるまで(TABLE以外の間まわる)
Set objOYA_TAG = objOYA_TAG.parentElement 'さらに、一つ上の親タグを代入
Wend
'↑必ずTHの上にTABLEがあると仮定して、エラー処理はしてないけど・・・
'テーブルが見つかったので、コピーする。
Set r = Me.WebBrowser1.Document.body.createControlRange
r.Add objOYA_TAG '上で見つけたテーブルを指定する。
r.Select 'セレクト 選択
Me.WebBrowser1.ExecWB 12, 0 'コマンド発行 OLECMDID_COPY = 12 コピー
Set r = Nothing 'Rは用済み
'形式を選択して貼り付け HTML貼り付けのテスト
Range("I1").Select
ActiveSheet.PasteSpecial Format:="HTML"
End Sub
↑、こんな感じで、単体のテストじゃないけど、取り出しができました。
