Attribute VB_Name = "MarathonStats" '========================================================================== ' MarathonStats Module ' ' Fetches live sports statistics from Marathon Bet (BY) and outputs ' results to a well-formatted Excel worksheet. ' ' URL: https://www.marathonbet.by/su/live/45356 ' Usage: Run macro "FetchMarathonStats" from Excel (Alt+F8) ' ' Fetch method: MSXML2.XMLHTTP (primary) / WinHttp (fallback) ' Parse method: InStr-based HTML parsing targeting Marathon's DOM markers '========================================================================== Option Explicit ' --------------------------------------------------------------------------- ' Configuration ' --------------------------------------------------------------------------- Private Const PAGE_URL As String = "https://www.marathonbet.by/su/live/45356" Private Const WS_NAME As String = "LiveStats" Private Const DATA_START_ROW As Long = 6 Private Const NUM_COLS As Long = 8 ' --------------------------------------------------------------------------- ' Color palette (Long = BGR) ' --------------------------------------------------------------------------- Private Const CLR_TITLE_BG As Long = 7360544 ' dark teal Private Const CLR_HDR_BG As Long = 10053171 ' medium blue-gray Private Const CLR_SPORT_BG As Long = 14994616 ' light steel blue Private Const CLR_ALT_ROW As Long = 15790320 ' very light gray Private Const CLR_WHITE As Long = 16777215 Private Const CLR_BORDER As Long = 12566463 ' medium gray ' --------------------------------------------------------------------------- ' Event data structure ' --------------------------------------------------------------------------- Private Type TEvent League As String Team1 As String Team2 As String Score As String MatchTime As String Odds1 As String Odds2 As String End Type Private m_Events() As TEvent Private m_Count As Long Private m_Sport As String ' =========================================================================== ' PUBLIC: Main entry point ' =========================================================================== Public Sub FetchMarathonStats() On Error GoTo Fail Application.ScreenUpdating = False Application.Cursor = xlWait m_Count = 0 m_Sport = "" Dim ws As Worksheet Set ws = SetupSheet() ' --- Fetch HTML via COM HTTP --- Application.StatusBar = "Fetching page..." Dim html As String html = FetchPage(PAGE_URL) If Len(html) < 200 Then ws.Range("A" & DATA_START_ROW).Value = _ "Failed to fetch page. Check internet connection." ws.Range("A" & DATA_START_ROW).Font.Italic = True Application.StatusBar = False MsgBox "Could not retrieve page content." & vbCrLf & _ "Verify network is available.", _ vbCritical, "Fetch Error" GoTo Done End If ' --- Parse HTML --- Application.StatusBar = "Parsing events..." ParseHTML html ' --- Write results --- If m_Count > 0 Then Application.StatusBar = "Formatting output..." WriteStructuredData ws FormatDataSheet ws ws.Activate: ws.Range("A1").Select Application.StatusBar = False MsgBox m_Count & " events loaded." & vbCrLf & _ "(" & m_Count & " " & ChrW(1089) & ChrW(1086) & ChrW(1073) & _ ChrW(1099) & ChrW(1090) & ChrW(1080) & ChrW(1081) & ")", _ vbInformation, "Marathon Stats" Else WriteTitle ws ws.Range("A" & DATA_START_ROW).Value = _ "No live events found on page. Try again when live games are active." ws.Range("A" & DATA_START_ROW).Font.Italic = True Application.StatusBar = False MsgBox "No live events found.", vbExclamation, "Marathon Stats" End If GoTo Done Fail: MsgBox "Error #" & Err.Number & ": " & Err.Description, vbCritical, "Error" Done: On Error Resume Next Application.Cursor = xlDefault Application.StatusBar = False Application.ScreenUpdating = True End Sub ' =========================================================================== ' FETCH: Try multiple COM HTTP methods ' =========================================================================== Private Function FetchPage(url As String) As String ' Method 1: MSXML2.XMLHTTP.6.0 (auto-decompresses gzip) FetchPage = FetchWithXMLHTTP(url) If Len(FetchPage) > 200 Then Exit Function ' Method 2: WinHttp with identity encoding (no gzip) FetchPage = FetchWithWinHTTP(url) End Function ' --- Primary: MSXML2.XMLHTTP.6.0 --- Private Function FetchWithXMLHTTP(url As String) As String On Error GoTo Fail Dim http As Object Set http = CreateObject("MSXML2.XMLHTTP.6.0") http.Open "GET", url, False http.setRequestHeader "User-Agent", _ "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 " & _ "(KHTML, like Gecko) Chrome/120.0.0.0 Safari/537.36" http.setRequestHeader "Accept-Language", "ru-RU,ru;q=0.9" http.setRequestHeader "Accept", "text/html,application/xhtml+xml" http.Send If http.Status = 200 Then ' ResponseBody -> ADODB.Stream for reliable UTF-8 decoding Dim bodyBytes() As Byte bodyBytes = http.responseBody Dim stream As Object Set stream = CreateObject("ADODB.Stream") With stream .Type = 1 ' binary .Open .Write bodyBytes .Position = 0 .Type = 2 ' text .Charset = "UTF-8" FetchWithXMLHTTP = .ReadText .Close End With End If Exit Function Fail: FetchWithXMLHTTP = "" End Function ' --- Fallback: WinHttp.WinHttpRequest.5.1 with identity encoding --- Private Function FetchWithWinHTTP(url As String) As String On Error GoTo Fail Dim http As Object Set http = CreateObject("WinHttp.WinHttpRequest.5.1") http.Open "GET", url, False http.setRequestHeader "User-Agent", _ "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 " & _ "(KHTML, like Gecko) Chrome/120.0.0.0 Safari/537.36" http.setRequestHeader "Accept-Language", "ru-RU,ru;q=0.9" http.setRequestHeader "Accept", "text/html,application/xhtml+xml" http.setRequestHeader "Accept-Encoding", "identity" http.Send If http.Status = 200 Then ' ResponseBody -> ADODB.Stream for reliable UTF-8 decoding Dim bodyBytes() As Byte bodyBytes = http.responseBody Dim stream As Object Set stream = CreateObject("ADODB.Stream") With stream .Type = 1 ' binary .Open .Write bodyBytes .Position = 0 .Type = 2 ' text .Charset = "UTF-8" FetchWithWinHTTP = .ReadText .Close End With End If Exit Function Fail: FetchWithWinHTTP = "" End Function ' =========================================================================== ' PARSE: Extract events from Marathon HTML ' =========================================================================== Private Sub ParseHTML(html As String) ' Detect sport type from data-sport-type attribute m_Sport = DetectSport(html) ' Sequential scan through HTML for known markers Dim pos As Long Dim curLeague As String Dim curScore As String Dim curTime As String pos = 1 curLeague = "" curScore = "" curTime = "" Do ' Find the next occurrence of each marker Dim posLabel As Long: posLabel = InStr(pos, html, "category-label simple-live") Dim posScore As Long: posScore = InStr(pos, html, "cl-left red") Dim posTeam As Long: posTeam = InStr(pos, html, "data-member-link=""true"">") ' Nothing left to find If posLabel = 0 And posScore = 0 And posTeam = 0 Then Exit Do ' Find the minimum positive position Dim minPos As Long: minPos = 2147483647 If posLabel > 0 And posLabel < minPos Then minPos = posLabel If posScore > 0 And posScore < minPos Then minPos = posScore If posTeam > 0 And posTeam < minPos Then minPos = posTeam ' --- Category label (league name) --- If minPos = posLabel And posLabel > 0 Then curLeague = ExtractLeague(html, posLabel) pos = posLabel + 30 ' --- Score line --- ElseIf minPos = posScore And posScore > 0 Then curScore = ExtractScore(html, posScore) curTime = ExtractGameTime(html, posScore) pos = posScore + 20 ' --- Team name (first of pair) --- ElseIf minPos = posTeam And posTeam > 0 Then Dim team1 As String team1 = ExtractTeamName(html, posTeam) pos = posTeam + 30 ' Find the second team Dim posTeam2 As Long posTeam2 = InStr(pos, html, "data-member-link=""true"">") If posTeam2 = 0 Then Exit Do Dim team2 As String team2 = ExtractTeamName(html, posTeam2) pos = posTeam2 + 30 ' Find odds (first 2 data-selection-price after team2, before next event) Dim odds1 As String, odds2 As String ExtractOddsPair html, pos, odds1, odds2 ' Store event AddEvent curLeague, team1, team2, curScore, curTime, odds1, odds2 curScore = "" curTime = "" End If Loop End Sub ' =========================================================================== ' EXTRACT HELPERS ' =========================================================================== ' --- Sport type from data-sport-type="..." --- Private Function DetectSport(html As String) As String Dim marker As String: marker = "data-sport-type=""" Dim p As Long: p = InStr(1, html, marker) If p = 0 Then DetectSport = "Basketball" Exit Function End If p = p + Len(marker) Dim q As Long: q = InStr(p, html, """") If q > p Then Dim raw As String: raw = Mid(html, p, q - p) ' Translate to Russian Select Case LCase(raw) Case "basketball": DetectSport = ChrW(1041) & ChrW(1072) & ChrW(1089) & ChrW(1082) & ChrW(1077) & ChrW(1090) & ChrW(1073) & ChrW(1086) & ChrW(1083) Case "football", "soccer": DetectSport = ChrW(1060) & ChrW(1091) & ChrW(1090) & ChrW(1073) & ChrW(1086) & ChrW(1083) Case "icehockey": DetectSport = ChrW(1061) & ChrW(1086) & ChrW(1082) & ChrW(1082) & ChrW(1077) & ChrW(1081) Case "tennis": DetectSport = ChrW(1058) & ChrW(1077) & ChrW(1085) & ChrW(1085) & ChrW(1080) & ChrW(1089) Case Else: DetectSport = raw End Select Else DetectSport = "Basketball" End If End Function ' --- League name from

...

--- Private Function ExtractLeague(html As String, startPos As Long) As String ' Find the > that opens the h2 tag content Dim p As Long: p = InStr(startPos, html, ">") If p = 0 Then Exit Function p = p + 1 ' Find Dim q As Long: q = InStr(p, html, "") If q = 0 Or q - p > 500 Then Exit Function Dim raw As String: raw = Mid(html, p, q - p) ExtractLeague = StripTags(raw) End Function ' --- Score from
content --- Private Function ExtractScore(html As String, startPos As Long) As String ' Find the > that opens the div Dim p As Long: p = InStr(startPos, html, ">") If p = 0 Then Exit Function p = p + 1 ' Take content up to time-description marker or
' Use just "time-description" for flexible matching Dim q1 As Long: q1 = InStr(p, html, "time-description") Dim q2 As Long: q2 = InStr(p, html, "") Dim q As Long If q1 > 0 And (q2 = 0 Or q1 < q2) Then ' Back up to the opening < of the span tag Dim backTrack As Long: backTrack = q1 Do While backTrack > p And Mid(html, backTrack, 1) <> "<" backTrack = backTrack - 1 Loop If backTrack > p Then q = backTrack Else q = q1 Else q = q2 End If If q = 0 Or q <= p Or q - p > 300 Then Exit Function Dim raw As String: raw = Mid(html, p, q - p) ExtractScore = CleanText(StripTags(raw)) End Function ' --- Game time from
near the score --- Private Function ExtractGameTime(html As String, scorePos As Long) As String ' Look for "green bold nobr" within 300 chars after score position Dim marker As String: marker = "green bold nobr" Dim p As Long: p = InStr(scorePos, html, marker) If p = 0 Or p - scorePos > 300 Then Exit Function ' Find the > to get content p = InStr(p, html, ">") If p = 0 Then Exit Function p = p + 1 ' Find
Dim q As Long: q = InStr(p, html, "") If q = 0 Or q - p > 50 Then Exit Function ExtractGameTime = CleanText(StripTags(Mid(html, p, q - p))) End Function ' --- Team name from TeamName --- Private Function ExtractTeamName(html As String, startPos As Long) As String Dim marker As String: marker = "data-member-link=""true"">" Dim p As Long: p = InStr(startPos, html, marker) If p = 0 Then Exit Function p = p + Len(marker) Dim q As Long: q = InStr(p, html, "") If q = 0 Or q - p > 100 Then Exit Function ExtractTeamName = Trim(Mid(html, p, q - p)) End Function ' --- Extract first 2 odds after position, bounded by next event/category --- Private Sub ExtractOddsPair(html As String, afterPos As Long, _ ByRef odds1 As String, ByRef odds2 As String) odds1 = "" odds2 = "" ' Determine boundary: next team marker or next category Dim boundary As Long: boundary = Len(html) Dim b1 As Long: b1 = InStr(afterPos, html, "data-member-link=""true"">") Dim b2 As Long: b2 = InStr(afterPos, html, "category-label simple-live") If b1 > 0 And b1 < boundary Then boundary = b1 If b2 > 0 And b2 < boundary Then boundary = b2 ' Find first odds Dim marker As String: marker = "data-selection-price=""" Dim p1 As Long: p1 = InStr(afterPos, html, marker) If p1 = 0 Or p1 > boundary Then Exit Sub odds1 = ExtractOddsAt(html, p1) ' Find second odds Dim p2 As Long: p2 = InStr(p1 + 20, html, marker) If p2 = 0 Or p2 > boundary Then Exit Sub odds2 = ExtractOddsAt(html, p2) End Sub ' --- Extract single odds value from data-selection-price="X" --- Private Function ExtractOddsAt(html As String, startPos As Long) As String Dim marker As String: marker = "data-selection-price=""" Dim p As Long: p = InStr(startPos, html, marker) If p = 0 Then Exit Function p = p + Len(marker) Dim q As Long: q = InStr(p, html, """") If q = 0 Or q - p > 15 Then Exit Function ExtractOddsAt = Mid(html, p, q - p) End Function ' --- Strip HTML tags and control characters from a string --- Private Function StripTags(s As String) As String Dim result As String Dim inTag As Boolean Dim i As Long Dim ch As String Dim code As Long For i = 1 To Len(s) ch = Mid(s, i, 1) code = AscW(ch) If ch = "<" Then inTag = True ElseIf ch = ">" Then inTag = False ElseIf Not inTag Then ' Replace newlines/tabs/control chars with space If code = 10 Or code = 13 Or code = 9 Then result = result & " " Else result = result & ch End If End If Next i ' Collapse multiple spaces Do While InStr(result, " ") > 0 result = Replace(result, " ", " ") Loop StripTags = Trim(result) End Function ' --- Clean text: strip newlines, tabs, collapse whitespace --- Private Function CleanText(s As String) As String Dim r As String: r = s r = Replace(r, vbCrLf, " ") r = Replace(r, vbCr, " ") r = Replace(r, vbLf, " ") r = Replace(r, vbTab, " ") ' Collapse multiple spaces Do While InStr(r, " ") > 0 r = Replace(r, " ", " ") Loop CleanText = Trim(r) End Function ' =========================================================================== ' EVENT STORAGE ' =========================================================================== Private Sub AddEvent(League As String, Team1 As String, Team2 As String, _ Score As String, MatchTime As String, _ Odds1 As String, Odds2 As String) ' Skip entries with empty teams If Len(Trim(Team1)) = 0 Or Len(Trim(Team2)) = 0 Then Exit Sub m_Count = m_Count + 1 ReDim Preserve m_Events(1 To m_Count) With m_Events(m_Count) .League = Trim(League) .Team1 = Trim(Team1) .Team2 = Trim(Team2) .Score = Trim(Score) .MatchTime = Trim(MatchTime) .Odds1 = Trim(Odds1) .Odds2 = Trim(Odds2) End With End Sub ' =========================================================================== ' WORKSHEET SETUP ' =========================================================================== Private Function SetupSheet() As Worksheet Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Worksheets(WS_NAME) On Error GoTo 0 If ws Is Nothing Then Set ws = ThisWorkbook.Worksheets.Add( _ After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) ws.Name = WS_NAME Else ws.Cells.Clear ws.Cells.Interior.ColorIndex = xlNone ws.Cells.Borders.LineStyle = xlNone ws.Cells.Font.Bold = False ws.Cells.Font.Italic = False ' Reset freeze panes ws.Activate ActiveWindow.FreezePanes = False End If Set SetupSheet = ws End Function ' =========================================================================== ' WRITE STRUCTURED DATA ' =========================================================================== Private Sub WriteStructuredData(ws As Worksheet) ' --- Title --- WriteTitle ws ' --- Column headers (row 5) --- Dim hdrRow As Long: hdrRow = DATA_START_ROW - 1 ' #, Liga, Komanda 1, Komanda 2, Schet, Vremya, P1, P2 ws.Cells(hdrRow, 1).Value = "#" ws.Cells(hdrRow, 2).Value = ChrW(1051) & ChrW(1080) & ChrW(1075) & ChrW(1072) ' Лига ws.Cells(hdrRow, 3).Value = ChrW(1050) & ChrW(1086) & ChrW(1084) & ChrW(1072) & _ ChrW(1085) & ChrW(1076) & ChrW(1072) & " 1" ' Команда 1 ws.Cells(hdrRow, 4).Value = ChrW(1050) & ChrW(1086) & ChrW(1084) & ChrW(1072) & _ ChrW(1085) & ChrW(1076) & ChrW(1072) & " 2" ' Команда 2 ws.Cells(hdrRow, 5).Value = ChrW(1057) & ChrW(1095) & ChrW(1105) & ChrW(1090) ' Счёт ws.Cells(hdrRow, 6).Value = ChrW(1042) & ChrW(1088) & ChrW(1077) & ChrW(1084) & _ ChrW(1103) ' Время ws.Cells(hdrRow, 7).Value = ChrW(1055) & "1" ' П1 ws.Cells(hdrRow, 8).Value = ChrW(1055) & "2" ' П2 ' --- Data rows --- Dim r As Long For r = 1 To m_Count Dim dataRow As Long: dataRow = DATA_START_ROW + r - 1 With m_Events(r) ws.Cells(dataRow, 1).Value = r ws.Cells(dataRow, 2).Value = .League ws.Cells(dataRow, 3).Value = .Team1 ws.Cells(dataRow, 4).Value = .Team2 ws.Cells(dataRow, 5).Value = .Score ws.Cells(dataRow, 6).Value = .MatchTime ws.Cells(dataRow, 7).Value = .Odds1 ws.Cells(dataRow, 8).Value = .Odds2 End With Next r End Sub ' =========================================================================== ' TITLE SECTION ' =========================================================================== Private Sub WriteTitle(ws As Worksheet) ' Row 1: Title with sport name Dim title As String If Len(m_Sport) > 0 Then title = "Marathon Bet " & ChrW(8212) & " " & m_Sport & " Live" Else title = "Marathon Bet " & ChrW(8212) & " Live " & _ ChrW(1057) & ChrW(1090) & ChrW(1072) & ChrW(1090) & _ ChrW(1080) & ChrW(1089) & ChrW(1090) & ChrW(1080) & _ ChrW(1082) & ChrW(1072) End If ws.Range("A1").Value = title ws.Range("A1").Font.Size = 16 ws.Range("A1").Font.Bold = True ws.Range("A1:H1").Merge ws.Range("A1").Interior.Color = CLR_TITLE_BG ws.Range("A1").Font.Color = CLR_WHITE ws.Range("A1").RowHeight = 30 ws.Range("A1").VerticalAlignment = xlVAlignCenter ' Row 2: URL ws.Range("A2").Value = PAGE_URL ws.Range("A2").Font.Size = 9 ws.Range("A2").Font.Color = &H999999 ws.Range("A2:H2").Merge ' Row 3: Timestamp ws.Range("A3").Value = ChrW(1044) & ChrW(1072) & ChrW(1090) & ChrW(1072) & _ ": " & Format(Now, "dd.mm.yyyy hh:nn:ss") ws.Range("A3").Font.Size = 9 ws.Range("A3").Font.Italic = True ws.Range("A3:H3").Merge End Sub ' =========================================================================== ' FORMAT DATA SHEET ' =========================================================================== Private Sub FormatDataSheet(ws As Worksheet) Dim lastRow As Long: lastRow = DATA_START_ROW + m_Count - 1 Dim lastCol As Long: lastCol = NUM_COLS Dim hdrRow As Long: hdrRow = DATA_START_ROW - 1 ' --- Header row --- With ws.Range(ws.Cells(hdrRow, 1), ws.Cells(hdrRow, lastCol)) .Interior.Color = CLR_HDR_BG .Font.Color = CLR_WHITE .Font.Bold = True .Font.Size = 10 .HorizontalAlignment = xlHAlignCenter .VerticalAlignment = xlVAlignCenter .RowHeight = 24 End With ' --- Data rows --- Dim r As Long Dim prevLeague As String For r = DATA_START_ROW To lastRow ' Alternating row colors If (r - DATA_START_ROW) Mod 2 = 1 Then ws.Range(ws.Cells(r, 1), ws.Cells(r, lastCol)).Interior.Color = CLR_ALT_ROW End If ' League group shading Dim cellLeague As String cellLeague = CStr(ws.Cells(r, 2).Value) If cellLeague <> prevLeague And Len(cellLeague) > 0 Then ws.Range(ws.Cells(r, 1), ws.Cells(r, lastCol)).Interior.Color = CLR_SPORT_BG ws.Cells(r, 2).Font.Bold = True prevLeague = cellLeague End If ' Row number - centered, gray ws.Cells(r, 1).HorizontalAlignment = xlHAlignCenter ws.Cells(r, 1).Font.Color = &H888888 ' Score - bold, centered, larger ws.Cells(r, 5).Font.Bold = True ws.Cells(r, 5).HorizontalAlignment = xlHAlignCenter ws.Cells(r, 5).Font.Size = 11 ' Time - centered ws.Cells(r, 6).HorizontalAlignment = xlHAlignCenter ' Odds - centered ws.Cells(r, 7).HorizontalAlignment = xlHAlignCenter ws.Cells(r, 8).HorizontalAlignment = xlHAlignCenter Next r ' --- Borders --- With ws.Range(ws.Cells(hdrRow, 1), ws.Cells(lastRow, lastCol)) .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeLeft).Color = CLR_BORDER .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlEdgeRight).Color = CLR_BORDER .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeTop).Color = CLR_BORDER .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).Color = CLR_BORDER .Borders(xlInsideHorizontal).LineStyle = xlContinuous .Borders(xlInsideHorizontal).Color = CLR_BORDER .Borders(xlInsideHorizontal).Weight = xlThin .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideVertical).Color = CLR_BORDER .Borders(xlInsideVertical).Weight = xlThin End With ' --- Column widths --- ws.Columns(1).ColumnWidth = 5 ' # ws.Columns(2).ColumnWidth = 38 ' League ws.Columns(3).ColumnWidth = 26 ' Team 1 ws.Columns(4).ColumnWidth = 26 ' Team 2 ws.Columns(5).ColumnWidth = 22 ' Score ws.Columns(6).ColumnWidth = 10 ' Time ws.Columns(7).ColumnWidth = 9 ' P1 ws.Columns(8).ColumnWidth = 9 ' P2 ' --- Freeze panes --- ws.Range("A" & DATA_START_ROW).Select ActiveWindow.FreezePanes = True ' --- Print setup --- On Error Resume Next With ws.PageSetup .Orientation = xlLandscape .FitToPagesWide = 1 .FitToPagesTall = False .PrintTitleRows = "$" & hdrRow & ":$" & hdrRow End With On Error GoTo 0 ' --- Footer --- Dim footerRow As Long: footerRow = lastRow + 2 ws.Cells(footerRow, 1).Value = ChrW(1042) & ChrW(1089) & ChrW(1077) & _ ChrW(1075) & ChrW(1086) & " " & ChrW(1089) & ChrW(1086) & _ ChrW(1073) & ChrW(1099) & ChrW(1090) & ChrW(1080) & ChrW(1081) & _ ": " & m_Count ws.Cells(footerRow, 1).Font.Italic = True ws.Cells(footerRow, 1).Font.Size = 9 ws.Cells(footerRow, 1).Font.Color = &H888888 End Sub