スポーツナビプロ野球一球速報のコメントをExelで表示

楽天の試合をニコ生で見ているとビジターの時はコメントなくて物足りなくなってしまうね。 スポナビの一球速報のコメントをみたりしているんだけど余白が多くて一度に３つぐらいのコメントしか見れないのが不満だったからExcelで表示できるようにしてみたよ。 A1 取得間隔（秒） B1 1行の文字数 C1 ホーム側コメント色　　　　　1:黒 2:白 3:赤 4:緑 5:青 6:黄 7:紫 8:水色 D1 ビジター側コメント色　　　　1:黒 2:白 3:赤 4:緑 5:青 6:黄 7:紫 8:水色 E1 　URL Excel2000以外でちゃんと動作するかどうかわからないけどVBAはこんな感じ。 無限Loopなので停止するときはctrl+Break。 Sub スポナビ()On Error GoTo ErrorTrapDim oHttp       As ObjectDim strURL      As StringDim strText     As StringDim arrData()   As StringDim GetText     As StringDim wIdx1       As LongDim wRow        As LongDim wMaxRow     As LongDim wStrno      As LongDim wEndno      As LongDim coment As StringDim comentd As StringDim comentn As LongDim comentmax As LongDim iro As LongDim mojisu As LongDim start As LongDim xxx(0) As StringDim i As IntegerDim StrFN As StringSheets("Sheet2").Select    strURL = Cells(1, 5)    mojisu = Cells(1, 2)Do    comentmax = Cells(2, 4)        'クリア    wMaxRow = Cells(Rows.Count, 5).End(xlUp).Row    If wMaxRow < 2 Then wMaxRow = 2    Range("A2:" & "E" & wMaxRow).ClearContents            wRow = 2    wStrno = 1       'オブジェクト変数に参照セットする    Set oHttp = CreateObject("MSXML2.XMLHTTP")        With oHttp        'URL読み込み        .Open "GET", strURL, False        'キャッシュが読み込まれないように        .setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"                .send                If (.Status < 200 Or .Status >= 300) Then 'ステータスのチェック                    MsgBox "URL読み込みに失敗しました", vbExclamation + vbOKOnly, "Error!"            Set oHttp = Nothing            GoTo ExitTrap        End If                    If InStr(1, .ResponseText, "野球実況掲示板") = 0 Then '野球実況掲示板かどうかチェック            MsgBox "時系列データが見つかりません", vbInformation + vbOKOnly            Set oHttp = Nothing            GoTo ExitTrap        End If                        For i = 1 To 15 '最大取得コメント数は15にしている                 'HTMLソースから[コメントNo]取り出し             Call 文字列抽出(wStrno, wEndno, GetText, .ResponseText, "<div class=""comment"" data-comment=""", """>")                          Cells(wRow, 4) = GetText             comentn = GetText                         wStrno = wEndno + 1                     'HTMLソースからコメントがホーム側かビジター側かで色を変える             Call 文字列抽出(wStrno, wEndno, GetText, .ResponseText, "<div class=""teamFlag""><span class=""", """></span></div>")                          iro = Cells(1, 3)             If InStr(1, GetText, "home") = 0 Then iro = Cells(1, 4)             wStrno = wEndno + 1                           'HTMLソースからコメント切り出し             Call 文字列抽出(wStrno, wEndno, GetText, .ResponseText, "<p class=""comText"">", "</p>")             strText = GetText                                 wStrno = wEndno + 1                  'コメントの1行区切りごとに配列セット         arrData = Split(strText, "<br />", , vbTextCompare)                    For wIdx1 = LBound(arrData) To UBound(arrData)                                                coment = Replace(arrData(wIdx1), vbLf, "") '改行削除                coment = Replace(arrData(wIdx1), vbCrLf, "") '改行削除                coment = Replace(coment, ">", ">") '> を < に変換                coment = Replace(coment, "…", "…") '… を … に変換                coment = Replace(coment, "→", "→") '→ を → に変換                                               'コメントを指定文字数毎に区切って表示                start = 1                Do                    comentd = Mid(coment, start, mojisu)                    If comentd = "" Then Exit Do                    If comentd = " " Then Exit Do                    Cells(wRow, 5) = comentd                    Cells(wRow, 5).Font.ColorIndex = iro                    wRow = wRow + 1                    start = start + mojisu                Loop                                            Next wIdx1            wRow = wRow + 1                       If wRow > 30 Then Exit For '最大行数は約30行にしている                    Next i    End With        ExitTrap:    'オブジェクト変数を解放する    Set oHttp = Nothing        'セルA1*1秒間待つ    For i = 1 To Cells(1, 1) * 2        DoEvents        Application.Wait [Now() + "0:00:00.5"]            Next iLoopExit SubErrorTrap:    'エラー処理    MsgBox "cmdKabukaGet_Click Error!" & Err.Number & ":" & Err.Description, vbExclamation + vbOKOnly, "Error!!"    Resume ExitTrap    End SubSub 文字列抽出(ByRef wStrno As Long, ByRef wEndno As Long, ByRef GetText As String, prmAllText As String, prmStrText As String, prmEndText As String)    '全体文字列(prmAllText)の中から開始文字列(prmStrText)～終了文字列(prmEndText)までの間の文字を取得する        wStrno = InStr(wStrno, prmAllText, prmStrText) + Len(prmStrText)   '開始文字列の次の文字位置を取得する    wEndno = InStr(wStrno, prmAllText, prmEndText)                  '終了文字列の位置を取得する    GetText = Mid(prmAllText, wStrno, wEndno - wStrno)              '開始文字列～終了文字列までの間の文字を取得するEnd Sub