JRA オッズ取得 馬連にチャレンジしてみた
Youtube LIVE↓でプログラムの説明を行ってみた。
https://youtube.com/live/8LA0P3fDvN0
youtube.com
と、言っても、
一部リンク条件の修正で、
リンク先の"ワイド"の文字を"馬連"に直しただけです。
00:00 1.まず、実行結果から見せる
テスト済みなので、実行結果から見せる
不具合:
馬連 ウマレンの読み上げが、
バレンと読んでしまう
03:38 2.馬連オッズ取得 簡単なコードの流れを説明する
06:41 リンクを探す
09:25 オッズページ、次のページをPOSTで開く
過去の参考動画
JRAホームページ「onClick=doAction が なんでPOSTだとわかったんですか？」と質問されたので
https://www.youtube.com/watch?v=NPnKju8rkVw
↑onClick=doActionの仕組みは、上記の動画を見てください。
13:52 開催日を探す B2と比較する
17:00 レースの選択
22:41 時刻の取り出し
25:00 馬連の表 TABLEからデータを取得してセットする
29:53 オッズをエクセルの作業シートへセットする
35:14 作業用からレース別のシートへセット
38:38 再度、馬連オッズの取得を走らせる
40:34 3.蛇足で馬単に挑戦して恥をかく・・・
44:26 馬単のテスト開始 空白を取得する不具合発生
47:33 再テスト 気分を変えて開催地を京都に変更して再テスト
取り消しが一番人気になるバグを発見
関連動画は再生リスト: https://www.youtube.com/playlist?list=PLBFC80A8658C305CE ←オッズ関係の再生リストを見てください
主な関連動画のリスト:
1.
CreateObject("htmlfile")でDocumentを作りweb上のhtmlデータを抜き出す 例としてJRAのHPからオッズを取得してみた
https://www.youtube.com/watch?v=RjZZUq40gxY
2.
JRAホームページ「onClick=doAction が なんでPOSTだとわかったんですか？」と質問されたので
https://www.youtube.com/watch?v=NPnKju8rkVw
3.
VBScript 定期実行 タスクスケジューラの設定テスト 終了設定でつまづく VBSを5分単位で実行させてみた
https://www.youtube.com/watch?v=4IkuWVECTVo
4.
ExcelVBAで表示変更 10倍以下を赤 小数点を0.0でそろえる 例題:JRA 単勝オッズ取得
https://youtu.be/rAi_uL41Bp0
5.
Excel 読み上げ Range(範囲).Speak で簡単にできます Application.Speech.Speakもアリかな
https://www.youtube.com/watch?v=c4mH9szOo2w
6.
BAT タスクスケジューラ から タスクを削除 schtasks /delete /tn タスクの名前 /f
https://youtu.be/Go7vpzyCPaI
↑16時09分 に タスクを削除するように仕込んでみます。
今回使用したソースコード:
#If Win64 Then Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If 'IEのリンクオブジェクトから文字列をInStrで探してクリックする Public Function IE_Link_InnerHTML_InStr_Click(oDocument As Object, strINSTR As String) As String Dim i As Integer Dim objA As HTMLAnchorElement Dim strWORK As String Dim n As Integer 'リンクから受け取った文字列を返す IE_Link_InnerHTML_InStr_Click = "ERR" '初期値にERRセット For i = 0 To oDocument.Links.Length - 1 '文字列を見つけたら クリック If InStr(oDocument.Links(i).outerHTML, strINSTR) > 0 Then '内側のHTML IE_Link_InnerHTML_InStr_Click = oDocument.Links(i).outerHTML '見つけたAタグオブジェ(リンク)を代入 Exit For '見つけたのでループを抜ける End If Next i End Function Public Function JRA_Bodyからオッズの時刻を返す(oDocument As Object) As String Dim strTEMP As String Dim strRETURN As String 'リターン値 Dim n As Integer 'errでリターン値を初期化 strRETURN = "ERR 文字列が見つかりませんでした" 'HTMLのBODYテキストを代入 strTEMP = oDocument.body.innerText 'まず最終オッズを探す If InStr(strTEMP, "最終オッズ") > 0 Then strRETURN = "最終" End If '探す 13時03分現在オッズ 2018/12/09 修正 '次週確認 7時03分現在オッズ 一けた台の時刻の時 n = InStr(strTEMP, "現在オッズ") If n > 0 Then strRETURN = Mid(strTEMP, n - 6, 6) '時刻を取り出す End If 'リターン値をセット strRETURN = Replace(strRETURN, vbLf, "") '改行vblfを""消す JRA_Bodyからオッズの時刻を返す = strRETURN End Function Public Function JRA_Bodyから発走時刻を返す(oDocument As Object) As String Dim strTEMP As String Dim strRETURN As String 'リターン値 Dim n As Integer 'errでリターン値を初期化 strRETURN = "発走時刻が見つかりませんでした" 'HTMLのBODYテキストを代入 strTEMP = oDocument.body.innerText '5回中山4日 発走時刻：13時05分 n = InStr(strTEMP, "発走時刻") If n > 0 Then strRETURN = Mid(strTEMP, n + 5, 6) '後ろの時刻を取り出す End If 'リターン値をセット JRA_Bodyから発走時刻を返す = strRETURN End Function
Option Explicit '20231007 馬連テスト Sub ie_JRA馬連オッズをレース別に複数蓄積する() '馬連の取得テスト ActiveWindow.WindowState = xlMinimized '最小表示 DoEvents Sleep 1000 '1秒待つ ActiveWindow.WindowState = xlNormal 'ノーマル表示 DoEvents 'JRA TOP ページの表示 '処理したいページをGET Dim strURL As String Dim strHTML As String strURL = "https://www.jra.go.jp/" strHTML = get_htmlfile(strURL) 'JRA TOPをGetする 'TOPページ文章に対して、処理を行います。 Dim i As Integer '添え字 i番目などで使用 Dim yLINE As Integer '行カウンタ、Y行目 Dim oDocument As Object Set oDocument = CreateObject("htmlfile") 'Set oDocument = New HTMLDocument '参照設定したとき 'oDocument.write "<html><body>test</body></html>" 'HTMLをセット 'Stop strHTML = Replace(strHTML, "script", "") 'scriptを止めるTEST oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ 'htmlfile_WAIT_TEST (oDocument) 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などを作るため Dim Waku_str As String Dim Waku_n As Integer 'リンクからオッズを押す Dim strLINK As String strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, "オッズ") If strLINK = "ERR" Then MsgBox "オッズが見つかりません" Stop End If 'オッズのページ HTMLを取り出す '<A onclick="doAction('/JRADB/accessO.html','pw15oli00/6D');return '文字列切り出し(strMOJI, "doAction('","','") '文字列切り出し(strMOJI, "','","')") Dim strPARA As String strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "','") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "','", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents '開催日のリンクをあさる strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, Sheets("MENU").Range("B2")) If strLINK = "ERR" Then MsgBox Sheets("MENU").Range("B2") & "が見つかりません" Stop End If strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "',") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "', '", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents '1R-12R 馬連の表を取り込む Dim r馬連の列 As Range '一番人気を探すため Dim n一番人気 As Integer '一番人気の馬番受け取る。馬番=位置なんだけど・・・ Dim strWORK As String 'C1にセットする文字列を作る Dim n馬番 As Integer '馬は最大18頭 Dim str初回FLG As String '初回は馬連をチェック、次からはレースのみで良い str初回FLG = "初回" '初回で初期化 '1Rから12Rまで、ループする。※これだと前日発売の時1Rでトラブルなぁ For nRACE = 1 To 12 '一から十二まで 'B5からのフラグが立っていたら And 最終じゃなければ 'レースを取り込む If Sheets("MENU").Range("B4").Offset(nRACE, 0) = 1 _ And Sheets("MENU").Range("B4").Offset(nRACE, 1) <> "最終" Then '出力先をクリアする 'まず、書き込み先シート、データをクリアする 'Sheets(nRACE & "R").Select 'シートの切り替え Sheets("作業用").Select 'シートの切り替え Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 SET_Y = 0 'セット位置を初期化 strRACE = nRACE & "レース" '1Rなど 文字にする 'リンクから該当するレースを探しクリックする "1R".."12R" If str初回FLG = "初回" Then '初回はレースと馬連を探す 'リンクから、レースのTR行を探し、列 ここでは馬連などを返す strLINK = IE_Link_InnerHTML_InStr_TR_TD(oDocument, strRACE, "馬連") str初回FLG = "次はレース選択のみ" 'フラグを折る。何を入れてもいい Else '２回目以降は、レースのみ選択で良い。馬連オッズの場所にいるので 'リンクから該当するレースを探しクリックする "1R".."12R" 'Call IE_Link_InnerHTML_InStr_Click(oDocument, """" & strRACE & """") strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, strRACE) End If If strLINK = "ERR" Then 'エラーチェック MsgBox strRACE & "が見つかりません" Stop End If strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "',") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "', '", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents 'Call IE_WAIT(objIE) 'ページの表示完了を待ちます。 'レース番号をセルに書く SET_Y = SET_Y + 1 Cells(SET_Y, 1) = Sheets("MENU").Range("B2") & " " & strRACE Cells(SET_Y, 2) = JRA_Bodyからオッズの時刻を返す(oDocument) Sheets("MENU").Range("C4").Offset(nRACE, 0) = JRA_Bodyからオッズの時刻を返す(oDocument) Debug.Print "オッズ:" & JRA_Bodyからオッズの時刻を返す(oDocument) '発送時刻のセット 'JRA_Bodyから発走時刻を返す Sheets("MENU").Range("A4").Offset(nRACE, 0) = strRACE & "発走" & JRA_Bodyから発走時刻を返す(oDocument) Debug.Print strRACE & "発走:" & JRA_Bodyから発走時刻を返す(oDocument) SET_Y = SET_Y + 1 '馬連の表を取り込む 表、テーブルを探る '見出しをセルに書く 馬番 - 馬番 馬連オッズ Cells(SET_Y, 1) = "馬番" Cells(SET_Y, 2) = "‐" Cells(SET_Y, 3) = "馬番" Cells(SET_Y, 4) = "馬連オッズ" SET_Y = SET_Y + 1 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 For n馬番 = 1 To 17 '馬番は最大18頭、17-18が最後なのでMAX17までループ 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = oDocument.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す｡ Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す 'テーブルのcaptionが処理する馬番かチェック If objTABLEs(i).Caption.innerText = n馬番 Then '一致したテーブルGet Set objTABLE = objTABLEs(i) 'みつけたらi番目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then '見つからなかったら、終わっていたら、ループを抜ける Exit For '抜ける End If '表をDATAシートに書き出す 'テーブルからデータを抜き出す、書き出す For y = 0 To objTABLE.Rows.Length - 1 '行のループ 'データをセルに書く 馬番 - 馬番 馬連オッズ Cells(SET_Y, 1) = objTABLEs(i).Caption.innerText '馬番 ここはテーブルのキャプション Cells(SET_Y, 2) = "‐" Cells(SET_Y, 3) = objTABLE.Rows(y).Cells(0).innerText '馬番 Cells(SET_Y, 4) = objTABLE.Rows(y).Cells(1).innerText '馬連オッズ そのままセット SET_Y = SET_Y + 1 Next y Next n馬番 SET_Y = SET_Y + 1 '空白を一行追加 '作業用シートからレース別に転記する Sheets(nRACE & "R").Select 'シートの切り替え '初回か判断 レース場や開催日が変わっているか判断 If Sheets("作業用").Range("A1") <> Range("A1") Then 'レース日や開催違いなら 'シートをクリア Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 '初回は、開催場所、見出しもコピーする Sheets("作業用").Range("A1:D" & SET_Y).Copy 'SET_Yまでコピー Range("A1").Select ActiveSheet.Paste 'オッズの時刻をセット Sheets("作業用").Range("B1").Copy Range("D2").Select ActiveSheet.Paste Set r馬連の列 = Range("D2") '初回はD2をセット 2022/05/15 Else '二回目以降は、後ろに追記 '元データをコピー Sheets("作業用").Range("D2:D" & SET_Y).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 Set r馬連の列 = Cells(2, x) '貼り付けたx列をセット 2022/05/15 '時刻を貼り付ける Sheets("作業用").Range("B1").Copy Cells(2, x).Select '貼り付け先を選択 ActiveSheet.Paste End If '10倍以下を赤に、小数点をそろえ、一番人気を探す 2022/05/15 n一番人気 = 馬連一番人気を探す(r馬連の列) '馬連の列から一番人気を探す strWORK = "馬連の一番人気は " strWORK = strWORK & Range("a2").Offset(n一番人気, 0) strWORK = strWORK & " ハイフン " strWORK = strWORK & Range("a2").Offset(n一番人気, 2) strWORK = strWORK & " オッズは " & r馬連の列.Offset(n一番人気, 0) & " です" Range("c1") = strWORK '読み上げる※動画用 DoEvents Range("B1").Clear Range("A1,C1").Speak 'A1とC1を読み上げ End If 'フラグが立っていたら↑ Next 'MENUに戻り、保存 Sheets("MENU").Select Range("A3").Select ActiveWorkbook.Save End Sub 'リンクから、レースのTR行を探し、列 ここでは馬連などを返す 20220924追加修正 'strLINK = IE_Link_InnerHTML_InStr_TR_TD(oDocument, strRACE, "馬連") 'IEのリンクオブジェクトから文字列をInStrで探して返す Public Function IE_Link_InnerHTML_InStr_TR_TD(oDocument As Object, _ strレース As String, _ str種類 As String) As String Dim i As Integer Dim objA As HTMLAnchorElement Dim strWORK As String Dim n As Integer 'まず、リンクから受け取ったレース文字列を返す IE_Link_InnerHTML_InStr_TR_TD = "ERR" '初期値にERRセット For i = 0 To oDocument.Links.Length - 1 'レースの文字列を見つけたら クリックじゃなかった次の種類を探す If InStr(oDocument.Links(i).outerHTML, strレース) > 0 Then '内側のHTML '本当は、見つけた行、TRを取得して、その中のTDを探した方がかっこいいけど 'ここでは、カウンターのiを使い、iより後ろで見つかったものを返す 'iとnのループカウンタ、添え時に注意してね For n = i + 1 To oDocument.Links.Length - 1 'レースの文字列を見つけたら クリックじゃなかった次の種類を探す If InStr(oDocument.Links(n).outerHTML, str種類) > 0 Then '内側のHTML IE_Link_InnerHTML_InStr_TR_TD = oDocument.Links(n).outerHTML '見つけたAタグオブジェ(リンク)を代入 Exit For '↑同じ行TRのチェックしてないけど・・・ End If Next n Exit For '見つけたのでループを抜ける ↑が同じTR行内のチェックしてないけどね・・・ End If Next i Debug.Print "リターン:" & IE_Link_InnerHTML_InStr_TR_TD End Function '2022/09/24 追加 馬連の列 先頭(見出しの部分)を受け取り一番人気を返す Public Function 馬連一番人気を探す(r As Range) As Integer Dim オッズ As Double Dim 一番人気 As Integer Dim n As Integer '初期値を代入 'val("10.1 - 11.5") みたいにすると変換されるので、Valで手抜き変換 オッズ = Val(r.Offset(1, 0)) '馬番1のオッズを初期値にする 一番人気 = 1 '上から1番目を初期セット For n = 1 To 18 * 17 'MAX18*17まわす、といっても途中で抜けるならForじゃなくても・・ With r.Offset(n, 0) 'n下のセルを操作したり値を比べる If Len(Trim("" & .Value)) = 0 Then Exit For 'データ無しなら抜ける '10倍以下なら、赤にする If Val(.Value) < 10 Then .Font.Color = -16776961 '赤にする End If 'オッズを比べる If Val(.Value) < オッズ Then '一時保存されているオッズより低かったら オッズ = Val(.Value) 'オッズを代入 更新 一番人気 = n '馬番nをセット End If End With Next 馬連一番人気を探す = 一番人気 'リターン値を返す '※まったく もう 日本語変数と関数名は良くないな・・・ End Function
Option Explicit '20231007 テスト Sub ie_JRA馬単オッズをレース別に複数蓄積する() '馬単の取得テスト ActiveWindow.WindowState = xlMinimized '最小表示 DoEvents Sleep 1000 '1秒待つ ActiveWindow.WindowState = xlNormal 'ノーマル表示 DoEvents 'JRA TOP ページの表示 '処理したいページをGET Dim strURL As String Dim strHTML As String strURL = "https://www.jra.go.jp/" strHTML = get_htmlfile(strURL) 'JRA TOPをGetする 'TOPページ文章に対して、処理を行います。 Dim i As Integer '添え字 i番目などで使用 Dim yLINE As Integer '行カウンタ、Y行目 Dim oDocument As Object Set oDocument = CreateObject("htmlfile") 'Set oDocument = New HTMLDocument '参照設定したとき 'oDocument.write "<html><body>test</body></html>" 'HTMLをセット 'Stop strHTML = Replace(strHTML, "script", "") 'scriptを止めるTEST oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ 'htmlfile_WAIT_TEST (oDocument) 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などを作るため Dim Waku_str As String Dim Waku_n As Integer 'リンクからオッズを押す Dim strLINK As String strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, "オッズ") If strLINK = "ERR" Then MsgBox "オッズが見つかりません" Stop End If 'オッズのページ HTMLを取り出す '<A onclick="doAction('/JRADB/accessO.html','pw15oli00/6D');return '文字列切り出し(strMOJI, "doAction('","','") '文字列切り出し(strMOJI, "','","')") Dim strPARA As String strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "','") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "','", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents '開催日のリンクをあさる strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, Sheets("MENU").Range("B2")) If strLINK = "ERR" Then MsgBox Sheets("MENU").Range("B2") & "が見つかりません" Stop End If strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "',") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "', '", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents '1R-12R 馬単の表を取り込む Dim r馬単の列 As Range '2022/09/24 一番人気を探すため Dim n一番人気 As Integer '一番人気の馬番受け取る。馬番=位置なんだけど・・・ Dim strWORK As String 'C1にセットする文字列を作る Dim n馬番 As Integer '馬は最大18頭 Dim str初回FLG As String '初回は馬単をチェック、次からはレースのみで良い str初回FLG = "初回" '初回で初期化 '1Rから12Rまで、ループする。※これだと前日発売の時1Rでトラブルなぁ For nRACE = 1 To 12 '一から十二まで 'B5からのフラグが立っていたら And 最終じゃなければ 'レースを取り込む If Sheets("MENU").Range("B4").Offset(nRACE, 0) = 1 _ And Sheets("MENU").Range("B4").Offset(nRACE, 1) <> "最終" Then '出力先をクリアする 'まず、書き込み先シート、データをクリアする 'Sheets(nRACE & "R").Select 'シートの切り替え Sheets("作業用").Select 'シートの切り替え Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 SET_Y = 0 'セット位置を初期化 strRACE = nRACE & "レース" '1Rなど 文字にする 'リンクから該当するレースを探しクリックする "1R".."12R" If str初回FLG = "初回" Then '初回はレースと馬単を探す 'リンクから、レースのTR行を探し、列 ここでは馬単などを返す strLINK = IE_Link_InnerHTML_InStr_TR_TD(oDocument, strRACE, "馬単") str初回FLG = "次はレース選択のみ" 'フラグを折る。何を入れてもいい Else '２回目以降は、レースのみ選択で良い。馬単オッズの場所にいるので 'リンクから該当するレースを探しクリックする "1R".."12R" 'Call IE_Link_InnerHTML_InStr_Click(oDocument, """" & strRACE & """") strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, strRACE) End If If strLINK = "ERR" Then 'エラーチェック MsgBox strRACE & "が見つかりません" Stop End If strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "',") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "', '", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents 'Call IE_WAIT(objIE) 'ページの表示完了を待ちます。 'レース番号をセルに書く SET_Y = SET_Y + 1 Cells(SET_Y, 1) = Sheets("MENU").Range("B2") & " " & strRACE Cells(SET_Y, 2) = JRA_Bodyからオッズの時刻を返す(oDocument) Sheets("MENU").Range("C4").Offset(nRACE, 0) = JRA_Bodyからオッズの時刻を返す(oDocument) Debug.Print "オッズ:" & JRA_Bodyからオッズの時刻を返す(oDocument) '発送時刻のセット 'JRA_Bodyから発走時刻を返す Sheets("MENU").Range("A4").Offset(nRACE, 0) = strRACE & "発走" & JRA_Bodyから発走時刻を返す(oDocument) Debug.Print strRACE & "発走:" & JRA_Bodyから発走時刻を返す(oDocument) SET_Y = SET_Y + 1 '馬単の表を取り込む 表、テーブルを探る '見出しをセルに書く 馬番 - 馬番 馬単オッズ Cells(SET_Y, 1) = "馬番" Cells(SET_Y, 2) = "‐" Cells(SET_Y, 3) = "馬番" Cells(SET_Y, 4) = "馬単オッズ" SET_Y = SET_Y + 1 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 For n馬番 = 1 To 18 '馬番は最大18頭、18-1,18-17があるので、MAX18までループ 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = oDocument.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す｡ Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す 'テーブルのcaptionが処理する馬番かチェック If objTABLEs(i).Caption.innerText = n馬番 Then '一致したテーブルGet Set objTABLE = objTABLEs(i) 'みつけたらi番目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then '見つからなかったら、終わっていたら、ループを抜ける Exit For '抜ける End If '表をDATAシートに書き出す 'テーブルからデータを抜き出す、書き出す For y = 0 To objTABLE.Rows.Length - 1 '行のループ If Trim("" & objTABLE.Rows(y).Cells(1).innerText) <> "" Then '1-1,2-2などをチェック 'データをセルに書く 馬番 - 馬番 馬単オッズ Cells(SET_Y, 1) = objTABLEs(i).Caption.innerText '馬番 ここはテーブルのキャプション Cells(SET_Y, 2) = "‐" Cells(SET_Y, 3) = objTABLE.Rows(y).Cells(0).innerText '馬番 Cells(SET_Y, 4) = objTABLE.Rows(y).Cells(1).innerText '馬単オッズ SET_Y = SET_Y + 1 End If Next y Next n馬番 SET_Y = SET_Y + 1 '空白を一行追加 '作業用シートからレース別に転記する Sheets(nRACE & "R").Select 'シートの切り替え '初回か判断 レース場や開催日が変わっているか判断 If Sheets("作業用").Range("A1") <> Range("A1") Then 'レース日や開催違いなら 'シートをクリア Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 '初回は、開催場所、見出しもコピーする Sheets("作業用").Range("A1:D" & SET_Y).Copy 'SET_Yまでコピー Range("A1").Select ActiveSheet.Paste 'オッズの時刻をセット Sheets("作業用").Range("B1").Copy Range("D2").Select ActiveSheet.Paste Set r馬単の列 = Range("D2") '初回はD2をセット 2022/05/15 Else '二回目以降は、後ろに追記 '元データをコピー Sheets("作業用").Range("D2:D" & SET_Y).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 Set r馬単の列 = Cells(2, x) '貼り付けたx列をセット 2022/05/15 '時刻を貼り付ける Sheets("作業用").Range("B1").Copy Cells(2, x).Select '貼り付け先を選択 ActiveSheet.Paste End If '10倍以下を赤に、小数点をそろえ、一番人気を探す 2022/05/15 n一番人気 = 馬単一番人気を探す(r馬単の列) '馬単の列から一番人気を探す strWORK = "馬単の一番人気は " strWORK = strWORK & Range("a2").Offset(n一番人気, 0) strWORK = strWORK & " ハイフン " strWORK = strWORK & Range("a2").Offset(n一番人気, 2) strWORK = strWORK & " オッズは " & r馬単の列.Offset(n一番人気, 0) & " です" Range("c1") = strWORK '読み上げる※動画用 DoEvents Range("B1").Clear Range("A1,C1").Speak 'A1とC1を読み上げ End If 'フラグが立っていたら↑ Next 'MENUに戻り、保存 Sheets("MENU").Select Range("A3").Select ActiveWorkbook.Save End Sub '2022/09/24 追加 馬単の列 先頭(見出しの部分)を受け取り一番人気を返す Public Function 馬単一番人気を探す(r As Range) As Integer Dim オッズ As Double Dim 一番人気 As Integer Dim n As Integer '初期値を代入 'val("10.1 - 11.5") みたいにすると変換されるので、Valで手抜き変換 オッズ = Val(r.Offset(1, 0)) '馬番1のオッズを初期値にする 一番人気 = 1 '上から1番目を初期セット For n = 1 To 18 * 17 'MAX18*17まわす、といっても途中で抜けるならForじゃなくても・・ With r.Offset(n, 0) 'n下のセルを操作したり値を比べる If Len(Trim("" & .Value)) = 0 Then Exit For 'データ無しなら抜ける '10倍以下なら、赤にする If Val(.Value) < 10 Then .Font.Color = -16776961 '赤にする End If 'オッズを比べる If Val(.Value) < オッズ Then '一時保存されているオッズより低かったら オッズ = Val(.Value) 'オッズを代入 更新 一番人気 = n '馬番nをセット End If End With Next 馬単一番人気を探す = 一番人気 'リターン値を返す '※まったく もう 日本語変数と関数名は良くないな・・・ End Function
他の関連ソースコードは、下記blogを見てください
1.単勝オッズ
ken3memo.hatenablog.com
2.ワイド
ken3memo.hatenablog.com
3.三連複
ken3memo.hatenablog.com
よろしくお願いします。
