Excel VBAで表示変更 10倍以下を赤小数点を0.0でそろえる例題:JRA 単勝オッズ取得

1.小数点をそろえる、オッズ10倍以下を赤にする
見た目を少し、修正してみます。
時間稼ぎの見た目修正よりも、異常なオッズや勝ち馬を探すロジックを組み込めよ・・・
なんて、声が聞こえてきますが。。。

下記、いつものあのあの解説動画です・・・
youtu.be
https://youtu.be/rAi_uL41Bp0

2.いつものマクロ記録で作成ぉぃぉぃ
コードをマクロ記録から探ってみます

'小数点を00.0にする
    Range("E4").Select
    Selection.NumberFormatLocal = "0.0"
'色を赤にする
    Range("E4:E6").Select
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With

このコードを組み込みました。

3.オッズの桁と色を変える、ついでに一番人気の馬番(位置)を求める

'2022/05/15 追加 単勝の列 先頭(見出しの部分)を受け取り一番人気を返す
'ついでに 10倍以下のオッズを赤に、小数点の桁をそろえる
Public Function 単勝一番人気を探す(r As Range) As Integer
    Dim オッズ As Double
    Dim 一番人気 As Integer
    
    '初期値を代入
    オッズ = r.Offset(1, 0) '馬番1のオッズを初期値にする
    一番人気 = 1  '馬番1を初期セット
    
    For n = 1 To 18  'MAX18頭まわす、といっても途中で抜けるならForじゃなくても・・
        With r.Offset(n, 0)  'n下のセルを操作したり値を比べる
            If Len(Trim("" & .Value)) = 0 Then Exit For 'データ無しなら抜ける
            '99.9 と 小数点の桁をそろえる
            .NumberFormatLocal = "0.0"
            '10倍以下なら、赤にする
            If .Value < 10 Then
                .Font.Color = -16776961 '赤にする
            End If
            'オッズを比べる
            If .Value < オッズ Then  '一時保存されているオッズより低かったら
                オッズ = .Value 'オッズを代入 更新
                一番人気 = n  '馬番nをセット
            End If
        End With
    Next
    
    単勝一番人気を探す = 一番人気  'リターン値を返す
    '※まったく もう 日本語変数と関数名は良くないな・・・

End Function

'↑今日作成したコード

すべてのソース、昔の必要ないコードも・・・ぉぃぉぃ、ハヤクまとめろよ

#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




'処理を強引に待つ？ oDocument As Object の中身をチェック
Sub htmlfile_WAIT_TEST(oDocument As Object)
    Dim date05 As Date   '5秒後の時刻
    date05 = DateAdd("s", 5, Now())
    
    Do While True
        If Now() < date05 Then Exit Do
        Sleep 250  '0.25秒
        Debug.Print Now()
        On Error Resume Next
        If oDocument.body.innerText > 0 Then Exit Do
        On Error GoTo 0
    Wend
    
End Sub

'20220501 テスト
Sub ie_JRA単勝オッズをレース別に複数蓄積する()  '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)  'パラメーターを付けて開く
    
    oDocument.write strHTML  '取得したHTMLをセット
    DoEvents
    Sleep 1000  '1秒待つ
    DoEvents

'1R-12R 単勝の表を取り込む
    
    Dim r単勝の列 As Range   '2022/05/15追加 10倍以下を赤くする、小数点そろえる
    Dim n一番人気 As Integer '一番人気の馬番受け取る。馬番=位置なんだけど・・・
    Dim strWORK As String    'C1にセットする文字列を作る
    
    '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"
            'Call IE_Link_InnerHTML_InStr_Click(oDocument, """" & strRACE & """")
            strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, strRACE)
            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
        
            '単勝の表を取り込む
            '表、テーブルを探る
            'テーブルを探す
            'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
            
            'TABLEタグを抜き 複数のテーブルをセット
            Set objTABLEs = oDocument.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)
                    
                    'X=0 一番左端の枠の時 見出し行より下(y>0)で
                    If y > 0 And x = 0 Then  '枠と馬番
                        'imgのaltから枠の文字 次の数値を取り出す
                        Waku_n = InStr(objCELL.innerHTML, "枠")
                        If Waku_n > 0 Then
                            'img alt="枠4青" src="/JRADB/img/waku/4.png"></td
                            Waku_str = Mid(objCELL.innerHTML, Waku_n + 1, 1)
                            Cells(SET_Y, SET_X) = Waku_str  'データセット
                            
                            '結合セル、枠などに対応
                            If objCELL.rowSpan > 1 Then  '縦に複数の時
                                
                                Cells(SET_Y + 1, SET_X) = Waku_str  '下にも同じくセット
                                'ホントはループがいいけど、一枠に三頭までなので
                                If objCELL.rowSpan = 3 Then  '3頭め ８枠18番など・・
                                    Cells(SET_Y + 2, SET_X) = Waku_str
                                End If
                            End If
                        Else  '枠じゃなく、馬番の時
                            '既にデータありか、縦に結合されているか？
                            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                                SET_X = SET_X + 1  '縦結合を飛ばすために横に移動
                            End If
                            
                            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
                        End If
                    Else
                        '結合セル以外
                        Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
                    End If
                    
                    '横に結合されているか判断じゃなかった、横にカラム分移動
                    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
                Set r単勝の列 = Range("D2")   '初回はD2をセット 2022/05/15
            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
                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 = "一番人気は" & n一番人気 & "番 " & Range("c2").Offset(n一番人気, 0)
            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



'URLを受け取り、HTML文字列を返す(シフトJISページ用に変換後)
Public Function get_htmlfile(strURL As String) As String

    Dim objDOC As Object
    
    Set objHTML = CreateObject("MSXML2.XMLHTTP")
    
    objHTML.Open "GET", strURL, False
    'objHTML.overrideMimeType "text/plain; charset=Shift_JIS"
    DoEvents
    objHTML.send
    Sleep 250  '0.25秒待つ

    DoEvents
    Do While objHTML.readyState <> 4
        DoEvents
    Loop
    
    Dim strHTML As String
    'strHTML = objHTML.responseText
    strHTML = StrConv(objHTML.responseBody, vbUnicode)

    'テキスト確認 デバッグ用
    Dim strFNAME As String
    strFNAME = ThisWorkbook.Path & "\testhtml.txt"
    Open strFNAME For Output As #1
    Print #1, Now() & " に実行"
    Print #1, "strURL:" & strURL
    Print #1, strHTML
    Close #1

    'Debug.Print strHTML
    Sleep 250  '0.25秒待つ
    get_htmlfile = strHTML  'リターン値で返す

End Function


'URL,パラメータを受け取り、HTML文字列を返す(シフトJISページ用に変換後)
Public Function get_htmlfile_post(strURL As String, strPARA As String) As String

    Dim objHTML As Object
    
    Set objHTML = CreateObject("MSXML2.XMLHTTP")
    
    objHTML.Open "POST", strURL, False
    objHTML.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    objHTML.send (strPARA)
    DoEvents
    Sleep 250  '0.25秒待つ

    DoEvents
    Do While objHTML.readyState <> 4
        DoEvents
    Loop
    
    Dim strHTML As String
    'strHTML = objHTML.responseText
    strHTML = StrConv(objHTML.responseBody, vbUnicode)

    'テキスト確認 デバッグ用
    Dim strFNAME As String
    strFNAME = ThisWorkbook.Path & "\testhtml.txt"
    Open strFNAME For Output As #1
    Print #1, Now() & " に実行"
    Print #1, "strURL:" & strURL
    Print #1, "strPARA:" & strPARA
    Print #1, strHTML  'HTML
    Close #1

    'Debug.Print strHTML
    
    get_htmlfile_post = strHTML  'リターン値で返す

End Function

'左右のキーワードを受け取り、文字を切り出す
'<A onclick="doAction('/JRADB/accessO.html','pw15oli00/6D');return
'文字列切り出し(strMOJI, "doAction('","','")
'文字列切り出し(strMOJI, "','","')")
Public Function 文字列切り出し(strMOJI As String, strLEFT As String, strRIGHT As String) As String

    文字列切り出し = ""  'データ無しで初期化

    Dim nLEFT  As Integer
    Dim nSTART As Integer
    Dim n      As Integer
    
    '左側の位置を探す
    n = InStr(strMOJI, strLEFT)  '左側の区切り文字を探す
    If n = 0 Then Exit Function  '見つからない時抜ける
    
    '開始位置をセット
    nSTART = n + Len(strLEFT) '抜き取り開始位置

    '右側キーワードを探す
    n = InStr(nSTART, strMOJI, strRIGHT)  '右側の区切り文字を探す
    If n = 0 Then Exit Function  '見つからない時抜ける

    'MIDで抜き出す
    文字列切り出し = Mid(strMOJI, nSTART, (n - nSTART))

End Function

'2022/05/15 追加 単勝の列 先頭(見出しの部分)を受け取り一番人気を返す
'ついでに 10倍以下のオッズを赤に、小数点の桁をそろえる
Public Function 単勝一番人気を探す(r As Range) As Integer
    Dim オッズ As Double
    Dim 一番人気 As Integer
    
    '初期値を代入
    オッズ = r.Offset(1, 0) '馬番1のオッズを初期値にする
    一番人気 = 1  '馬番1を初期セット
    
    For n = 1 To 18  'MAX18頭まわす、といっても途中で抜けるならForじゃなくても・・
        With r.Offset(n, 0)  'n下のセルを操作したり値を比べる
            If Len(Trim("" & .Value)) = 0 Then Exit For 'データ無しなら抜ける
            '99.9 と 小数点の桁をそろえる
            .NumberFormatLocal = "0.0"
            '10倍以下なら、赤にする
            If .Value < 10 Then
                .Font.Color = -16776961 '赤にする
            End If
            'オッズを比べる
            If .Value < オッズ Then  '一時保存されているオッズより低かったら
                オッズ = .Value 'オッズを代入 更新
                一番人気 = n  '馬番nをセット
            End If
        End With
    Next
    
    単勝一番人気を探す = 一番人気  'リターン値を返す
    '※まったく もう 日本語変数と関数名は良くないな・・・

End Function