まぁ、たいした話じゃないのですが、
コピペでチョコチョコとパラメーターを変えて作成するプログラム
と
ループを使ったプログラムのお話です。
↓いつもの雑談動画 ぉぃぉぃ
www.youtube.com
単体のオッズを取得できたので、
次は、繰り返し、
1R-12Rまで、オッズを取得してみたいと思います。
1.コピペで縦に並べて作る
1Rが取得できたので、
次の2Rもソースをコピーして作る
※ぉぃぉぃ
下記7Rまでだけど、コピペで作成した クソプログラム ぉぃぉぃ
Sub ie_copy_pe() 'IEの表示をテストする。 'IEの起動 Dim objIE As InternetExplorer '変数を定義します。 Set objIE = CreateObject("InternetExplorer.Application") 'オブジェクトを作成します。 objIE.Visible = True '可視、Trueで見えるようにします。 '表示位置(左上の座標)とサイズ(高さ・幅)を調整する objIE.FullScreen = False '※Trueのモードだとびっくりするよ objIE.Top = 0 '左上 上位置 objIE.Left = 0 '左上 左位置 objIE.Width = 800 '横幅 objIE.Height = 600 '高さ 'XXXバー、外観・外枠の調整。 objIE.Toolbar = True 'タブの切り替えで必要なので、ツールバーを表示にする objIE.MenuBar = False 'メニューは非表示にする objIE.AddressBar = True 'URLなど アドレスバーは確認のため、表示する objIE.StatusBar = True '一番下のステータスバーを表示。 '処理したいページを表示します。 objIE.Navigate "http://www.jra.go.jp/" '.Navigate メソッドで JRA表示する。 'Navigate と Navigate2 の 違いが私もイマイチわかってませんが 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend 'ページが表示されたので、表示された文章に対して、処理を行います。 'HTML文章objIE.Documentからデータを取得 '入力フォームDocument.Formsでデータをセットしたり送信したり 'リンクDocument.Linksでリンクの情報を取得 Dim i As Integer '添え字 i番目などで使用 Dim yLINE As Integer '行カウンタ、Y行目 Dim oDocument As HTMLDocument Dim objA As HTMLAnchorElement Range("A1") = "調査したURLは " & strURL & " です" 'A1にURLを記述(セット) Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です" 'D1にリンクの数をセット Range("A2") = ".Href(リンク先)" 'A2~F2 2行目に見出しをセットする Range("B2") = ".OuterText" Range("C2") = ".OuterHTML" Range("D2") = ".InnerText" Range("E2") = ".InnerHTML" Range("F2") = ".Target" Columns("A:F").ColumnWidth = 22 '列幅を22に変更 yLINE = 3 'セット開始の行を代入する For i = 0 To objIE.Document.Links.Length - 1 'データをセルへセットする 'を付けて文字列にする(セルにセットしたいので) Cells(yLINE, "A") = "'" & objIE.Document.Links(i).href 'リンク先 Cells(yLINE, "B") = "'" & objIE.Document.Links(i).outerText '自分を含む テキスト(Innerと変わりない?) Cells(yLINE, "C") = "'" & objIE.Document.Links(i).outerHTML '自分を含む HTML Cells(yLINE, "D") = "'" & objIE.Document.Links(i).innerText '内側のテキスト Cells(yLINE, "E") = "'" & objIE.Document.Links(i).innerHTML '内側のHTML Cells(yLINE, "F") = "'" & objIE.Document.Links(i).target '_Blank や 表示先フレームの名前など 'オッズを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, "オッズ") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click 'オッズを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If yLINE = yLINE + 1 'セット位置(行)を+1する Next i '開催日を探す 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '開催日のリンクをあさる Range("A1") = "調査したURLは " & strURL & " です" 'A1にURLを記述(セット) Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です" 'D1にリンクの数をセット Range("A2") = ".Href(リンク先)" 'A2~F2 2行目に見出しをセットする Range("B2") = ".OuterText" Range("C2") = ".OuterHTML" Range("D2") = ".InnerText" Range("E2") = ".InnerHTML" Range("F2") = ".Target" Columns("A:F").ColumnWidth = 22 '列幅を22に変更 yLINE = 3 'セット開始の行を代入する For i = 0 To objIE.Document.Links.Length - 1 'データをセルへセットする 'を付けて文字列にする(セルにセットしたいので) Cells(yLINE, "A") = "'" & objIE.Document.Links(i).href 'リンク先 Cells(yLINE, "B") = "'" & objIE.Document.Links(i).outerText '自分を含む テキスト(Innerと変わりない?) Cells(yLINE, "C") = "'" & objIE.Document.Links(i).outerHTML '自分を含む HTML Cells(yLINE, "D") = "'" & objIE.Document.Links(i).innerText '内側のテキスト Cells(yLINE, "E") = "'" & objIE.Document.Links(i).innerHTML '内側のHTML Cells(yLINE, "F") = "'" & objIE.Document.Links(i).target '_Blank や 表示先フレームの名前など '開催日を見つけたら書き出す If Right(objIE.Document.Links(i).innerText, 1) = "日" Then '内側のTEXT Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 Debug.Print objA.innerText Debug.Print objA.innerHTML objA.Click '開催日を押す Exit For '見つけたのでループを抜ける End If yLINE = yLINE + 1 'セット位置(行)を+1する Next i '試しに1Rを取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend For i = 0 To objIE.Document.Links.Length - 1 '1Rを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, """1R""") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '1Rを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i '単勝の表を取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 Dim objTABLEs As Object 'TABLE複数の格納用 Dim objTABLE As HTMLTable 'テーブル単体 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = objIE.Document.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける Set objTABLE = objTABLEs(i) 'i盤目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then MsgBox "枠番のテーブルが見つかりません" Exit Sub 'エラー表示して抜ける End If 'まず、書き込み先シート、データをクリアする Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A2").Select '先頭A1を選択する、 '表をDATAシートに書き出す Dim x As Integer '列の管理 Dim y As Integer '行の管理 Dim SET_Y As Integer Dim SET_X As Integer Dim objCELL As HTMLTableCell SET_Y = 2 Cells(SET_Y - 1, 1) = "1R" 'Webの表をシートへ転記(代入する) For y = 0 To objTABLE.Rows.Length - 1 '行のループ SET_X = 1 For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ ' objTABLE.rows(行).cells(列) Set objCELL = objTABLE.Rows(y).Cells(x) If objCELL.rowSpan > 1 Then '縦に複数の時 Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット End If '既にデータありか、縦に結合されているか? If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then SET_X = SET_X + 1 End If Cells(SET_Y, SET_X) = objCELL.innerText 'データセット '横に結合されているか判断 SET_X = SET_X + objCELL.colSpan 'カラム分 横に移動 Next SET_Y = SET_Y + 1 Next 'copy '試しに2Rを取り込む For i = 0 To objIE.Document.Links.Length - 1 '1Rを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, """2R""") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '1Rを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i '単勝の表を取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = objIE.Document.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける Set objTABLE = objTABLEs(i) 'i盤目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then MsgBox "枠番のテーブルが見つかりません" Exit Sub 'エラー表示して抜ける End If '表をDATAシートに書き出す SET_Y = SET_Y + 2 Cells(SET_Y - 1, 1) = "2R" 'Webの表をシートへ転記(代入する) For y = 0 To objTABLE.Rows.Length - 1 '行のループ SET_X = 1 For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ ' objTABLE.rows(行).cells(列) Set objCELL = objTABLE.Rows(y).Cells(x) If objCELL.rowSpan > 1 Then '縦に複数の時 Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット End If '既にデータありか、縦に結合されているか? If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then SET_X = SET_X + 1 End If Cells(SET_Y, SET_X) = objCELL.innerText 'データセット '横に結合されているか判断 SET_X = SET_X + objCELL.colSpan 'カラム分 横に移動 Next SET_Y = SET_Y + 1 Next 'copy '試しに3Rを取り込む For i = 0 To objIE.Document.Links.Length - 1 '1Rを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, """3R""") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '1Rを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i '単勝の表を取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = objIE.Document.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける Set objTABLE = objTABLEs(i) 'i盤目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then MsgBox "枠番のテーブルが見つかりません" Exit Sub 'エラー表示して抜ける End If '表をDATAシートに書き出す SET_Y = SET_Y + 2 Cells(SET_Y - 1, 1) = "3R" 'Webの表をシートへ転記(代入する) For y = 0 To objTABLE.Rows.Length - 1 '行のループ SET_X = 1 For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ ' objTABLE.rows(行).cells(列) Set objCELL = objTABLE.Rows(y).Cells(x) If objCELL.rowSpan > 1 Then '縦に複数の時 Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット End If '既にデータありか、縦に結合されているか? If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then SET_X = SET_X + 1 End If Cells(SET_Y, SET_X) = objCELL.innerText 'データセット '横に結合されているか判断 SET_X = SET_X + objCELL.colSpan 'カラム分 横に移動 Next SET_Y = SET_Y + 1 Next 'copy '試しに4Rを取り込む For i = 0 To objIE.Document.Links.Length - 1 '1Rを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, """4R""") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '1Rを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i '単勝の表を取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = objIE.Document.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける Set objTABLE = objTABLEs(i) 'i盤目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then MsgBox "枠番のテーブルが見つかりません" Exit Sub 'エラー表示して抜ける End If '表をDATAシートに書き出す SET_Y = SET_Y + 2 Cells(SET_Y - 1, 1) = "4R" 'Webの表をシートへ転記(代入する) For y = 0 To objTABLE.Rows.Length - 1 '行のループ SET_X = 1 For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ ' objTABLE.rows(行).cells(列) Set objCELL = objTABLE.Rows(y).Cells(x) If objCELL.rowSpan > 1 Then '縦に複数の時 Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット End If '既にデータありか、縦に結合されているか? If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then SET_X = SET_X + 1 End If Cells(SET_Y, SET_X) = objCELL.innerText 'データセット '横に結合されているか判断 SET_X = SET_X + objCELL.colSpan 'カラム分 横に移動 Next SET_Y = SET_Y + 1 Next 'copy '試しに5Rを取り込む For i = 0 To objIE.Document.Links.Length - 1 '1Rを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, """5R""") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '1Rを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i '単勝の表を取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = objIE.Document.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける Set objTABLE = objTABLEs(i) 'i盤目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then MsgBox "枠番のテーブルが見つかりません" Exit Sub 'エラー表示して抜ける End If '表をDATAシートに書き出す SET_Y = SET_Y + 2 Cells(SET_Y - 1, 1) = "5R" 'Webの表をシートへ転記(代入する) For y = 0 To objTABLE.Rows.Length - 1 '行のループ SET_X = 1 For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ ' objTABLE.rows(行).cells(列) Set objCELL = objTABLE.Rows(y).Cells(x) If objCELL.rowSpan > 1 Then '縦に複数の時 Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット End If '既にデータありか、縦に結合されているか? If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then SET_X = SET_X + 1 End If Cells(SET_Y, SET_X) = objCELL.innerText 'データセット '横に結合されているか判断 SET_X = SET_X + objCELL.colSpan 'カラム分 横に移動 Next SET_Y = SET_Y + 1 Next 'copy '試しに6Rを取り込む For i = 0 To objIE.Document.Links.Length - 1 '1Rを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, """6R""") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '1Rを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i '単勝の表を取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = objIE.Document.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける Set objTABLE = objTABLEs(i) 'i盤目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then MsgBox "枠番のテーブルが見つかりません" Exit Sub 'エラー表示して抜ける End If '表をDATAシートに書き出す SET_Y = SET_Y + 2 Cells(SET_Y - 1, 1) = "6R" 'Webの表をシートへ転記(代入する) For y = 0 To objTABLE.Rows.Length - 1 '行のループ SET_X = 1 For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ ' objTABLE.rows(行).cells(列) Set objCELL = objTABLE.Rows(y).Cells(x) If objCELL.rowSpan > 1 Then '縦に複数の時 Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット End If '既にデータありか、縦に結合されているか? If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then SET_X = SET_X + 1 End If Cells(SET_Y, SET_X) = objCELL.innerText 'データセット '横に結合されているか判断 SET_X = SET_X + objCELL.colSpan 'カラム分 横に移動 Next SET_Y = SET_Y + 1 Next 'copy '試しに7Rを取り込む For i = 0 To objIE.Document.Links.Length - 1 '1Rを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, """7R""") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '1Rを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i '単勝の表を取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = objIE.Document.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける Set objTABLE = objTABLEs(i) 'i盤目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then MsgBox "枠番のテーブルが見つかりません" Exit Sub 'エラー表示して抜ける End If '表をDATAシートに書き出す SET_Y = SET_Y + 2 Cells(SET_Y - 1, 1) = "7R" 'Webの表をシートへ転記(代入する) For y = 0 To objTABLE.Rows.Length - 1 '行のループ SET_X = 1 For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ ' objTABLE.rows(行).cells(列) Set objCELL = objTABLE.Rows(y).Cells(x) If objCELL.rowSpan > 1 Then '縦に複数の時 Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット End If '既にデータありか、縦に結合されているか? If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then SET_X = SET_X + 1 End If Cells(SET_Y, SET_X) = objCELL.innerText 'データセット '横に結合されているか判断 SET_X = SET_X + objCELL.colSpan 'カラム分 横に移動 Next SET_Y = SET_Y + 1 Next '処理が終わったので、IEを閉じます。 'テストの時は、↓確認して、残しておくと便利ですよ。 If MsgBox("IEを閉じますか?", vbYesNo) = vbYes Then '終了確認 objIE.Quit '.Quitで閉じる End If Set objIE = Nothing '使用したオブジェクト変数もキレイにしてね。 End Sub
2.雑談
嫌いな先輩や上司に小言を言われたので、
むかついたから 作っちゃったよ
そんな
負のマイナスエネルギーをやる気に変える人達?
動画で、雑談を はさみつつ、
3.同じ処理は変数にして、ループでまわしましょ・・
まぁ、通常は
メンテもしやすいし、同じ処理はまとめましょう・・・
Sub ie_test() 'IEの表示をテストする。 'IEの起動 Dim objIE As InternetExplorer '変数を定義します。 Set objIE = CreateObject("InternetExplorer.Application") 'オブジェクトを作成します。 objIE.Visible = True '可視、Trueで見えるようにします。 '表示位置(左上の座標)とサイズ(高さ・幅)を調整する objIE.FullScreen = False '※Trueのモードだとびっくりするよ objIE.Top = 0 '左上 上位置 objIE.Left = 0 '左上 左位置 objIE.Width = 800 '横幅 objIE.Height = 600 '高さ 'XXXバー、外観・外枠の調整。 objIE.Toolbar = True 'タブの切り替えで必要なので、ツールバーを表示にする objIE.MenuBar = False 'メニューは非表示にする objIE.AddressBar = True 'URLなど アドレスバーは確認のため、表示する objIE.StatusBar = True '一番下のステータスバーを表示。 '処理したいページを表示します。 objIE.Navigate "http://www.jra.go.jp/" '.Navigate メソッドで JRA表示する。 'Navigate と Navigate2 の 違いが私もイマイチわかってませんが 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend 'ページが表示されたので、表示された文章に対して、処理を行います。 'HTML文章objIE.Documentからデータを取得 '入力フォームDocument.Formsでデータをセットしたり送信したり 'リンクDocument.Linksでリンクの情報を取得 Dim i As Integer '添え字 i番目などで使用 Dim yLINE As Integer '行カウンタ、Y行目 Dim oDocument As HTMLDocument Dim objA As HTMLAnchorElement Range("A1") = "調査したURLは " & strURL & " です" 'A1にURLを記述(セット) Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です" 'D1にリンクの数をセット Range("A2") = ".Href(リンク先)" 'A2~F2 2行目に見出しをセットする Range("B2") = ".OuterText" Range("C2") = ".OuterHTML" Range("D2") = ".InnerText" Range("E2") = ".InnerHTML" Range("F2") = ".Target" Columns("A:F").ColumnWidth = 22 '列幅を22に変更 yLINE = 3 'セット開始の行を代入する For i = 0 To objIE.Document.Links.Length - 1 'データをセルへセットする 'を付けて文字列にする(セルにセットしたいので) Cells(yLINE, "A") = "'" & objIE.Document.Links(i).href 'リンク先 Cells(yLINE, "B") = "'" & objIE.Document.Links(i).outerText '自分を含む テキスト(Innerと変わりない?) Cells(yLINE, "C") = "'" & objIE.Document.Links(i).outerHTML '自分を含む HTML Cells(yLINE, "D") = "'" & objIE.Document.Links(i).innerText '内側のテキスト Cells(yLINE, "E") = "'" & objIE.Document.Links(i).innerHTML '内側のHTML Cells(yLINE, "F") = "'" & objIE.Document.Links(i).target '_Blank や 表示先フレームの名前など 'オッズを見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, "オッズ") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click 'オッズを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If yLINE = yLINE + 1 'セット位置(行)を+1する Next i '開催日を探す 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '開催日のリンクをあさる Range("A1") = "調査したURLは " & strURL & " です" 'A1にURLを記述(セット) Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です" 'D1にリンクの数をセット Range("A2") = ".Href(リンク先)" 'A2~F2 2行目に見出しをセットする Range("B2") = ".OuterText" Range("C2") = ".OuterHTML" Range("D2") = ".InnerText" Range("E2") = ".InnerHTML" Range("F2") = ".Target" Columns("A:F").ColumnWidth = 22 '列幅を22に変更 yLINE = 3 'セット開始の行を代入する For i = 0 To objIE.Document.Links.Length - 1 'データをセルへセットする 'を付けて文字列にする(セルにセットしたいので) Cells(yLINE, "A") = "'" & objIE.Document.Links(i).href 'リンク先 Cells(yLINE, "B") = "'" & objIE.Document.Links(i).outerText '自分を含む テキスト(Innerと変わりない?) Cells(yLINE, "C") = "'" & objIE.Document.Links(i).outerHTML '自分を含む HTML Cells(yLINE, "D") = "'" & objIE.Document.Links(i).innerText '内側のテキスト Cells(yLINE, "E") = "'" & objIE.Document.Links(i).innerHTML '内側のHTML Cells(yLINE, "F") = "'" & objIE.Document.Links(i).target '_Blank や 表示先フレームの名前など '開催日を見つけたら書き出す If Right(objIE.Document.Links(i).innerText, 1) = "日" Then '内側のTEXT Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 Debug.Print objA.innerText Debug.Print objA.innerHTML objA.Click '開催日を押す Exit For '見つけたのでループを抜ける End If yLINE = yLINE + 1 'セット位置(行)を+1する Next i '試しに1Rを取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '1R-12R Dim objTABLEs As Object 'TABLE複数の格納用 Dim objTABLE As HTMLTable 'テーブル単体 Dim x As Integer '列の管理 Dim y As Integer '行の管理 Dim SET_Y As Integer Dim SET_X As Integer Dim objCELL As HTMLTableCell Dim nRACE As Integer Dim strRACE As String 'まず、書き込み先シート、データをクリアする Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 SET_Y = 0 'セット位置を初期化 For nRACE = 1 To 12 '一から十二まで strRACE = nRACE & "R" 'R1など 文字にする 'レース番号をセルに書く SET_Y = SET_Y + 1 Cells(SET_Y, 1) = strRACE SET_Y = SET_Y + 1 For i = 0 To objIE.Document.Links.Length - 1 '"1R"を見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, """" & strRACE & """") > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '1Rを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i '単勝の表を取り込む 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 DoEvents '重いので嫌いな人居るけど。 Wend '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = objIE.Document.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける Set objTABLE = objTABLEs(i) 'i盤目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then MsgBox "枠番のテーブルが見つかりません" Exit Sub 'エラー表示して抜ける End If '表をDATAシートに書き出す 'Webの表をシートへ転記(代入する) For y = 0 To objTABLE.Rows.Length - 1 '行のループ SET_X = 1 For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ ' objTABLE.rows(行).cells(列) Set objCELL = objTABLE.Rows(y).Cells(x) If objCELL.rowSpan > 1 Then '縦に複数の時 Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット End If '既にデータありか、縦に結合されているか? If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then SET_X = SET_X + 1 End If Cells(SET_Y, SET_X) = objCELL.innerText 'データセット '横に結合されているか判断 SET_X = SET_X + objCELL.colSpan 'カラム分 横に移動 Next SET_Y = SET_Y + 1 Next SET_Y = SET_Y + 1 '空白を一行追加 Next '処理が終わったので、IEを閉じます。 'テストの時は、↓確認して、残しておくと便利ですよ。 If MsgBox("IEを閉じますか?", vbYesNo) = vbYes Then '終了確認 objIE.Quit '.Quitで閉じる End If Set objIE = Nothing '使用したオブジェクト変数もキレイにしてね。 End Sub
↓※冒頭と同じ いつもの雑談動画 ぉぃぉぃ
www.youtube.com
雑談がむごいけど、こんな感じで極端な違いを感じ取ってもらえれば・・・