単勝オッズをレース別 取得時間別にためていきたいと思います
現在、最新のオッズを取得するところまでは、
バグ付きですがなんとかできました。
ここから、分岐して、
単勝オッズが時間の経過でどのように推移するか?
そんな分析をしたいので、
レース別 時間別にシートに保存、
そんな処理を行ってみたいと思います。
下記、↓いつもの迷っている ライブ動画です・・・
JRA単勝オッズをレース別に複数蓄積する VBA IE操作 Ken3 ライブ プログラミング テスト中 - YouTube
www.youtube.com
ポイントは、
単勝順のオッズを一時的に
Sheets("作業用")
に書き込む
次に、
1.初回は、馬番 馬の名前を書き込む
2.二回目以降は、時刻とオッズを書き込む
上記をポイントに処理を行ってみたいと思います。
初回のチェックは、
一枠一番の馬名が変化したかを単純にチェックしました。
あとは、単純にデータを作業用シートからレース1R..12Rにコピーしただけです。
'初回か判断 レース場や開催日が変わっているか 馬名で判断 If Sheets("作業用").Range("C3") <> Range("C3") Then 'C3馬名が違ったら 'シートをクリア Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 '初回は、馬名もコピーする Sheets("作業用").Range("A1:D20").Copy Range("A1").Select ActiveSheet.Paste 'オッズの時刻をセット Sheets("作業用").Range("B1").Copy Range("D2").Select ActiveSheet.Paste Else '二回目以降は、後ろに追記 '元データをコピー Sheets("作業用").Range("D2:D20").Copy 'オッズの列 '貼り付け先を探す For x = 1 To 256 '空白列を探す 'セル二行目のx列が空白か調べて抜ける If Len(Trim("" & Cells(2, x))) = 0 Then Exit For Next x Cells(2, x).Select '貼り付け先を選択 ActiveSheet.Paste '時刻を貼り付ける Sheets("作業用").Range("B1").Copy Cells(2, x).Select '貼り付け先を選択 ActiveSheet.Paste End If
↑上記のような 単純なコードですみません・・・・
頭からの 長いソースは、
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'IEオブジェクトを受け取り、表示を待つ Sub IE_WAIT(objIE As InternetExplorer) Sleep 250 '0.25秒待つ 'ページの表示完了を待ちます。 While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。 'DoEvents '重いので嫌いな人居るけど。 Sleep 200 '0.2秒待つ Wend Sleep 250 '0.25秒待つ End Sub 'IEのリンクオブジェクトから文字列をInStrで探してクリックする Sub IE_Link_InnerHTML_InStr_Click(objIE As InternetExplorer, strINSTR As String) Dim i As Integer Dim objA As HTMLAnchorElement 'リンクから受け取った文字列を探して押す For i = 0 To objIE.Document.Links.Length - 1 '文字列を見つけたら クリック If InStr(objIE.Document.Links(i).innerHTML, strINSTR) > 0 Then '内側のHTML Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '該当するリンクを押す 'objA.FireEvent ("onClick") 'onClick イベントを発行 Exit For '見つけたのでループを抜ける End If Next i End Sub Public Function JRA_Bodyからオッズの時刻を返す(objIE As InternetExplorer) As String Dim strTEMP As String Dim strRETURN As String 'リターン値 Dim n As Integer 'errでリターン値を初期化 strRETURN = "ERR 文字列が見つかりませんでした" 'HTMLのBODYテキストを代入 strTEMP = objIE.Document.body.innerText 'まず最終オッズを探す If InStr(strTEMP, "最終オッズ") > 0 Then strRETURN = "最終" End If 'XX現在を探す n = InStr(strTEMP, "現在オッズ") If n > 0 Then strRETURN = Mid(strTEMP, n - 5, 5) '時刻を取り出す End If 'リターン値をセット JRA_Bodyからオッズの時刻を返す = strRETURN End Function Sub ie_JRA単勝オッズをレース別に複数蓄積する() 'JRA 単勝オッズの取り込み 馬番順テスト '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 '一番下のステータスバーを表示。 'JRA TOP ページの表示 '処理したいページを表示します。 objIE.Navigate "http://www.jra.go.jp/" '.Navigate メソッドで JRA表示する。 Call IE_WAIT(objIE) 'ページの表示完了を待ちます。 'TOPページが表示されたので、表示された文章に対して、処理を行います。 Dim i As Integer '添え字 i番目などで使用 Dim yLINE As Integer '行カウンタ、Y行目 Dim oDocument As HTMLDocument Dim objA As HTMLAnchorElement Dim objTABLEs As Object 'TABLE複数の格納用 Dim objTABLE As HTMLTable 'テーブル単体 Dim x As Integer '列の管理 Dim y As Integer '行の管理 Dim SET_Y As Integer 'Excel側のセット位置 Dim SET_X As Integer 'Excel側のセット位置 Dim objCELL As HTMLTableCell Dim nRACE As Integer 'レース 1-12 Dim strRACE As String '文字列 1Rなどを作るため 'リンクからオッズを押す Call IE_Link_InnerHTML_InStr_Click(objIE, "オッズ") Call IE_WAIT(objIE) 'ページの表示完了を待ちます。 '開催日のリンクをあさる Set objA = Nothing For i = 0 To objIE.Document.Links.Length - 1 '開催場所 B2と一致を条件に判断する If objIE.Document.Links(i).innerText = Sheets("MENU").Range("B2") Then '内側のTEXT Set objA = objIE.Document.Links(i) '見つけたAタグオブジェ(リンク)を代入 objA.Click '開催日を押す Exit For '見つけたのでループを抜ける End If Next i If objA Is Nothing Then MsgBox Sheets("MENU").Range("B2") & " リンクが見つかりませんでした" Exit Sub End If Call IE_WAIT(objIE) 'ページの表示完了を待ちます。 '1R-12R 単勝の表を取り込む '1Rから12Rまで、ループする。※これだと前日発売の時1Rでトラブルなぁ For nRACE = 1 To 12 '一から十二まで 'B5からのフラグが立っていたらレースを取り込む If Sheets("MENU").Range("B4").Offset(nRACE, 0) = 1 Then '出力先をクリアする 'まず、書き込み先シート、データをクリアする 'Sheets(nRACE & "R").Select 'シートの切り替え Sheets("作業用").Select 'シートの切り替え Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 SET_Y = 0 'セット位置を初期化 strRACE = nRACE & "R" 'R1など 文字にする 'リンクから該当するレースを探しクリックする "1R".."12R" Call IE_Link_InnerHTML_InStr_Click(objIE, """" & strRACE & """") Call IE_WAIT(objIE) 'ページの表示完了を待ちます。 'レース番号をセルに書く SET_Y = SET_Y + 1 Cells(SET_Y, 1) = Sheets("MENU").Range("B2") & " " & strRACE Cells(SET_Y, 2) = JRA_Bodyからオッズの時刻を返す(objIE) Sheets("MENU").Range("B4").Offset(nRACE, 1) = JRA_Bodyからオッズの時刻を返す(objIE) Debug.Print JRA_Bodyからオッズの時刻を返す(objIE) SET_Y = SET_Y + 1 '単勝の表を取り込む '表、テーブルを探る 'テーブルを探す 'タグの取出しが、.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 '下にも同じくセット 'ホントはループがいいけど、一枠に三頭までなので If objCELL.rowSpan = 3 Then '3頭め 8枠18番など・・ Cells(SET_Y + 2, SET_X) = objCELL.innerText End If 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 '横に移動 通常は1 結合なし Next SET_Y = SET_Y + 1 Next SET_Y = SET_Y + 1 '空白を一行追加 '作業用シートからレース別に転記する Sheets(nRACE & "R").Select 'シートの切り替え '初回か判断 レース場や開催日が変わっているか 馬名で判断 If Sheets("作業用").Range("C3") <> Range("C3") Then 'C3馬名が違ったら 'シートをクリア Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 '初回は、馬名もコピーする Sheets("作業用").Range("A1:D20").Copy Range("A1").Select ActiveSheet.Paste 'オッズの時刻をセット Sheets("作業用").Range("B1").Copy Range("D2").Select ActiveSheet.Paste Else '二回目以降は、後ろに追記 '元データをコピー Sheets("作業用").Range("D2:D20").Copy 'オッズの列 '貼り付け先を探す For x = 1 To 256 '空白列を探す 'セル二行目のx列が空白か調べて抜ける If Len(Trim("" & Cells(2, x))) = 0 Then Exit For Next x Cells(2, x).Select '貼り付け先を選択 ActiveSheet.Paste '時刻を貼り付ける Sheets("作業用").Range("B1").Copy Cells(2, x).Select '貼り付け先を選択 ActiveSheet.Paste End If End If 'フラグが立っていたら↑ Next objIE.Quit '.Quitで閉じる Set objIE = Nothing '使用したオブジェクト変数もキレイにしてね。 End Sub
です。
まだまだ、先は長い感じですが、
たたき台、サンプルとして使い、
自由にアレンジしてみてください。。。。