alexei.dolgolyov/marathon-parser
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
main
marathon-parser/MarathonStats.bas
alexei.dolgolyov e48bca907d Replace curl.exe with native COM HTTP fetching 
Use MSXML2.XMLHTTP.6.0 (primary) and WinHttp.WinHttpRequest.5.1
(fallback) instead of shelling out to curl.exe. Fetch functions now
accept a url parameter for reusability.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-02-28 22:23:16 +03:00

703 lines
25 KiB
QBasic
Raw Permalink Blame History

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 <h2 ... class="category-label simple-live"><span>...</span></h2> ---
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 </h2>
Dim q As Long: q = InStr(p, html, "</h2>")
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 <div class="cl-left red"> 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 </div>
' 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, "</div>")
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 <div class="green bold nobr"> 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 </div>
Dim q As Long: q = InStr(p, html, "</div>")
If q = 0 Or q - p > 50 Then Exit Function
ExtractGameTime = CleanText(StripTags(Mid(html, p, q - p)))
End Function
' --- Team name from <span data-member-link="true">TeamName</span> ---
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, "</span>")
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
Reference in New Issue View Git Blame Copy Permalink