Option Explicit
' Copyright (c) Kenneth Parker, 2012 - 2016
Const FirstRow = 2
Const LastRow = 31
Const AnnualGames = 82
Private LastColumn
Private cDivisionQual
Private cHeadings
Private cHighlight
Private cInPlayoffPos
Private cInPlayoffs
Private cOutOfPlayoffPos
Private cOutOfPlayoffs
Private FirstWest
Private LastWest
Private FirstEast
Private LastEast
Private ConfSort
Function GetWebData() As Boolean
'
' Get standings data from ESPN.com
'
On Error GoTo NoWebData
GetWebData = False
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://espn.go.com/nhl/standings", Destination:=Range("$A$1"))
.Name = "standings"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True ' False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
GetWebData = True
NoWebData:
End Function
Function FindSomething(Thing)
'
' Search is in a separate function to isolate the On Error statement
'
On Error GoTo ThingNotFound
FindSomething = False
Cells.Find(What:=Thing, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
FindSomething = True
ThingNotFound:
End Function
Function RngCol(rng, Optional Rw = "", Optional ColAbs = False, Optional RowAbs = False)
'
' Return the columm letter(s) for range rng, optionally with a row, and optionally absolute
'
Dim r
On Error GoTo BadRange
RngCol = "?"
r = Range(rng).Address(True, False, xlA1)
RngCol = IIf(ColAbs, "$", "") & Left(r, InStr(r, "$") - 1) & _
IIf(RowAbs And Len(Rw) > 0, "$", "") & Rw
Exit Function
BadRange:
MsgBox "Range '" & rng & "' is not defined", vbOKOnly + vbCritical, "RngCol() Error"
End Function
Sub AddCheckBox(c, cbxNme, v, Optional rngName)
'
Dim rng As Range
Set rng = Range(c)
' Add the checkbox in cell C, name it Nme
ActiveSheet.CheckBoxes.Add(rng.Left, rng.Top, rng.Width / 2, rng.Height / 2).Select
Selection.Characters.Text = ""
Selection.Name = cbxNme
' Link the checkbox to cell C and check it based on V
If (v <> xlOn) And (v <> xlOff) Then
v = xlOff
End If
ActiveSheet.Shapes.Range(Array(cbxNme)).Select
With Selection
.Value = v
.LinkedCell = rng.Address(True, True, xlA1)
.Display3DShading = False
End With
' Unlock cell C so that checkbox changes will work
rng.Locked = False
' Set the text colour to the cell background colour so that it isn't visible
rng.Font.Color = ActiveCell.Interior.Color
' Apply rngName to cell C, if rngName is given
If Not IsMissing(rngName) Then
ActiveWorkbook.Names.Add Name:=rngName, RefersTo:="=" & rng.Address(True, True, xlA1)
End If
End Sub
Function NameExists(n, Optional scope = 0)
' scope: 0 - either global or local
' 1 - global
' 2 - local
' Returns: True - name found
' False - name not found
Dim z
n = LCase(n)
NameExists = False
For Each z In ActiveWorkbook.Names
If LCase(z.Name) = n And (scope = 0 Or scope = 1) Then
NameExists = True
Exit For
ElseIf LCase(z.Name) = (LCase(ActiveSheet.Name) & "!" & n) And (scope = 0 Or scope = 2) Then
NameExists = True
Exit For
End If
Next z
End Function
Function CheckboxExists(w, s, n)
' Returns: True if the named checkbox is on the specified sheet of the named workbook
' False otherwise
Dim z
CheckboxExists = False
For Each z In Workbooks(ThisWorkbook.Name).Sheets
If LCase(z.Name) = LCase(s) Then
CheckboxExists = True
Exit For
End If
Next z
If CheckboxExists Then
CheckboxExists = False
For Each z In Workbooks(ThisWorkbook.Name).Worksheets(s).CheckBoxes
If LCase(z.Name) = LCase(n) Then
CheckboxExists = True
Exit For
End If
Next z
End If
End Function
Sub MakeRange(RangeName, Colmn, EastWest As Boolean)
ActiveWorkbook.Names.Add Name:=RangeName, RefersTo:="=$" & Colmn & "$" & FirstRow & ":$" & Colmn & "$" & LastRow
If EastWest Then
ActiveWorkbook.Names.Add Name:=RangeName & "_W", RefersTo:="=$" & Colmn & "$" & FirstWest & ":$" & Colmn & "$" & LastWest
ActiveWorkbook.Names.Add Name:=RangeName & "_E", RefersTo:="=$" & Colmn & "$" & FirstEast & ":$" & Colmn & "$" & LastEast
End If
End Sub
Function BestWorstRank(ShowRange, TestRange)
'
Range(ShowRange).Select
' Playoff teams
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND(" & RngCol("ConfRank", 2) & "<=8,IF(RankByLeague," & _
"RANK.EQ(" & RngCol(TestRange, 2) & "," & TestRange & ",BestIsLow)=MIN(" & TestRange & ")," & _
"IF(" & RngCol("Conference", 2) & "=""W"",RANK.EQ(" & RngCol(TestRange, 2) & "," & TestRange & "_W,BestIsLow)=MIN(" & TestRange & "_W)," & _
"RANK.EQ(" & RngCol(TestRange, 2) & "," & TestRange & "_E,BestIsLow)=MIN(" & TestRange & "_E))))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.5
.Gradient.RectangleRight = 0.5
.Gradient.RectangleTop = 0.5
.Gradient.RectangleBottom = 0.5
.Gradient.ColorStops.Clear
End With
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0).Color = cHighlight
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1).Color = cInPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Non-playoff teams
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND(" & RngCol("ConfRank", 2) & ">8,IF(RankByLeague," & _
"RANK.EQ(" & RngCol(TestRange, 2) & "," & TestRange & ",BestIsLow)=MIN(" & TestRange & ")," & _
"IF(" & RngCol("Conference", 2) & "=""W"",RANK.EQ(" & RngCol(TestRange, 2) & "," & TestRange & "_W,BestIsLow)=MIN(" & TestRange & "_W)," & _
"RANK.EQ(" & RngCol(TestRange, 2) & "," & TestRange & "_E,BestIsLow)=MIN(" & TestRange & "_E))))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.5
.Gradient.RectangleRight = 0.5
.Gradient.RectangleTop = 0.5
.Gradient.RectangleBottom = 0.5
.Gradient.ColorStops.Clear
End With
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0).Color = cHighlight
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1).Color = cOutOfPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
End Function
Function BestWorstData(ShowRange, TestRange)
'
Range(ShowRange).Select
' Playoff teams
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND(AQ2<=8,IF(RankByLeague," & RngCol(TestRange, 2) & "=IF(MarkTop,MAX(" & TestRange & "),MIN(" & TestRange & "))," & _
"IF(" & RngCol("Conference", 2) & "=""W""," & RngCol(TestRange, 2) & "=IF(MarkTop,MAX(" & TestRange & "_W),MIN(" & TestRange & "_W))," & _
RngCol(TestRange, 2) & "=IF(MarkTop,MAX(" & TestRange & "_E),MIN(" & TestRange & "_E)))))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.5
.Gradient.RectangleRight = 0.5
.Gradient.RectangleTop = 0.5
.Gradient.RectangleBottom = 0.5
.Gradient.ColorStops.Clear
End With
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0).Color = cHighlight
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1).Color = cInPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Non-playoff teams
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND(AQ2>8,IF(RankByLeague," & RngCol(TestRange, 2) & "=IF(MarkTop,MAX(" & TestRange & "),MIN(" & TestRange & "))," & _
"IF(" & RngCol("Conference", 2) & "=""W""," & RngCol(TestRange, 2) & "=IF(MarkTop,MAX(" & TestRange & "_W),MIN(" & TestRange & "_W))," & _
RngCol(TestRange, 2) & "=IF(MarkTop,MAX(" & TestRange & "_E),MIN(" & TestRange & "_E)))))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.5
.Gradient.RectangleRight = 0.5
.Gradient.RectangleTop = 0.5
.Gradient.RectangleBottom = 0.5
.Gradient.ColorStops.Clear
End With
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0).Color = cHighlight
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1).Color = cOutOfPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
End Function
Sub GetData()
'
Dim FontDefault As Font
Dim FontHighlight As Font
Dim ReverseBold As Boolean
Dim cbBestWorst
Dim cbLeagueWide
Dim cbPlayoffs
Dim c
Dim cl As Range
Dim fnd
Dim i
Dim CopyTeams As Boolean
Dim NewBookName
Dim rng
Dim s
Dim ShowWork As Boolean
Dim TeamNames As Variant
Dim WestAtTop As Boolean
' Initialize array of team names
TeamNames = Array("Anaheim", "Arizona", "Boston", "Buffalo", "Calgary", "Carolina", "Chicago", "Colorado", "Columbus", "Dallas", "Detroit", "Edmonton", _
"Florida", "Los Angeles", "Minnesota", "Montréal", "Nashville", "New Jersey", "NY Islanders", "NY Rangers", "Ottawa", "Philadelphia", _
"Pittsburgh", "San Jose", "St. Louis", "Tampa Bay", "Toronto", "Vancouver", "Washington", "Winnipeg")
' Initialize default colours
cDivisionQual = RGB(255, 255, 153)
cHeadings = RGB(219, 238, 243)
cHighlight = RGB(255, 255, 0)
cInPlayoffPos = RGB(153, 255, 153)
cInPlayoffs = RGB(0, 255, 0)
cOutOfPlayoffPos = RGB(255, 204, 255)
cOutOfPlayoffs = RGB(255, 0, 0)
' Initialize default checkbox values
cbBestWorst = xlOn
cbLeagueWide = xlOn
cbPlayoffs = xlOn
WestAtTop = True
ShowWork = False
FirstWest = 2
LastWest = 15
FirstEast = 16
LastEast = 31
ConfSort = xlDescending
' Always use a new workbook
Workbooks.Add
NewBookName = ActiveWorkbook.Name
ActiveSheet.Name = "Standings"
For Each s In ActiveWorkbook.Sheets
If s.Name <> "Standings" Then
Application.DisplayAlerts = False
s.Delete
Application.DisplayAlerts = True
End If
Next s
' Error getting data from NHL.com - delete newly-created workbook & exit
If Not GetWebData Then
MsgBox "Unable to connect to NHL.com"
Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True
Exit Sub
End If
' Switch to macro workbook to facilitate copying default values, etc.
ThisWorkbook.Activate
' Get fonts for standings results
If NameExists("fDefaultFont") Then
Set FontDefault = Range("fDefaultFont").Font
Else
Set FontDefault = ActiveCell.Font
End If
' Get font for highlighted teams
If NameExists("fHighlightFont") Then
Set FontHighlight = Range("fHighlightFont").Font
ReverseBold = False
Else
Set FontHighlight = ActiveCell.Font
ReverseBold = True
End If
' Get colours if they are defined
If NameExists("cDivisionQual") Then
If Range("cDivisionQual").Interior.Color <> vbWhite Then
cDivisionQual = Range("cDivisionQual").Interior.Color
End If
End If
If NameExists("cHeadings") Then
If Range("cHeadings").Interior.Color <> vbWhite Then
cHeadings = Range("cHeadings").Interior.Color
End If
End If
If NameExists("cHighlight") Then
If Range("cHighlight").Interior.Color <> vbWhite Then
cHighlight = Range("cHighlight").Interior.Color
End If
End If
If NameExists("cInPlayoffPos") Then
If Range("cInPlayoffPos").Interior.Color <> vbWhite Then
cInPlayoffPos = Range("cInPlayoffPos").Interior.Color
End If
End If
If NameExists("cInPlayoffs") Then
If Range("cInPlayoffs").Interior.Color <> vbWhite Then
cInPlayoffs = Range("cInPlayoffs").Interior.Color
End If
End If
If NameExists("cOutOfPlayoffPos") Then
If Range("cOutOfPlayoffPos").Interior.Color <> vbWhite Then
cOutOfPlayoffPos = Range("cOutOfPlayoffPos").Interior.Color
End If
End If
If NameExists("cOutOfPlayoffs") Then
If Range("cOutOfPlayoffs").Interior.Color <> vbWhite Then
cOutOfPlayoffs = Range("cOutOfPlayoffs").Interior.Color
End If
End If
' Get values of checkboxes, if they exist
If CheckboxExists(ActiveWorkbook.Name, ActiveSheet.Name, "BestWorst") Then
cbBestWorst = ActiveSheet.CheckBoxes("BestWorst").Value
End If
If CheckboxExists(ActiveWorkbook.Name, ActiveSheet.Name, "LeagueWide") Then
cbLeagueWide = ActiveSheet.CheckBoxes("LeagueWide").Value
End If
If CheckboxExists(ActiveWorkbook.Name, ActiveSheet.Name, "Playoffs") Then
cbPlayoffs = ActiveSheet.CheckBoxes("Playoffs").Value
End If
WestAtTop = True
If CheckboxExists(ActiveWorkbook.Name, ActiveSheet.Name, "WestFirst") Then
WestAtTop = (ActiveSheet.CheckBoxes("WestFirst").Value = xlOn)
End If
ShowWork = False
If CheckboxExists(ActiveWorkbook.Name, ActiveSheet.Name, "ShowWork") Then
ShowWork = (ActiveSheet.CheckBoxes("ShowWork").Value = xlOn)
End If
If Not WestAtTop Then
FirstWest = 18
LastWest = 31
FirstEast = 2
LastEast = 17
ConfSort = xlAscending
End If
' Copy team sheet to new workbook`
fnd = False
For Each s In ActiveWorkbook.Sheets
If s.Name = "Teams" Then
Sheets("Teams").Copy After:=Workbooks(NewBookName).Sheets(1)
fnd = True
Exit For
End If
Next s
' Or create a team sheet if there wasn't one in the macro workbook
If Not fnd Then
Workbooks(NewBookName).Activate
Sheets.Add After:=Sheets(1)
ActiveSheet.Name = "Teams"
ActiveSheet.Tab.Color = RGB(226, 107, 10)
Range("A1").Formula = "Team"
Range("B1").Formula = "Highlight"
Range("A1:B1").Font.Underline = True
Range("C2").Select
ActiveWindow.FreezePanes = True
Range("B2").Select
For i = 1 To 30
Cells(i + 1, 1) = TeamNames(i - 1)
Next i
Columns("A:A").ColumnWidth = 15
Columns("B:B").EntireColumn.HorizontalAlignment = xlCenter
ActiveWorkbook.Names.Add Name:="TeamHighlights", RefersTo:="=Teams!$A$2:$B$31"
End If
' Return to new workbook & start formatting
If ShowWork Then
Application.ScreenUpdating = True
Else
Application.ScreenUpdating = False
End If
Sheets("Standings").Select
Range("A1").Select
ActiveWindow.DisplayGridlines = False
' Set font from macro workbook
With ActiveWorkbook.Styles("Normal").Font
.Name = FontDefault.Name
.Size = FontDefault.Size
.Bold = FontDefault.Bold
.Italic = FontDefault.Italic
.Color = FontDefault.Color
.Underline = xlUnderlineStyleNone
.Strikethrough = False
End With
' Delete unneeded rows before the standings table
If Not FindSomething("eastern conference") Then
MsgBox """League standings"" not found" & vbCr & _
"Please ensure that the active workbook contains proper data."
Exit Sub
End If
Rows("1:" & ActiveCell.Row).Delete Shift:=xlUp
' Delete unneeded rows after the standings table
If FindSomething("glossary") Then
Rows(ActiveCell.Row & ":" & ActiveCell.SpecialCells(xlLastCell).Row).Delete Shift:=xlUp
End If
' Define the number of games per year
ActiveWorkbook.Names.Add Name:="AnnualGames", RefersTo:="=" & AnnualGames
' Insert column A for conference ranking
Columns("A:A").Insert
Range("C2").Select
ActiveWindow.FreezePanes = True
' Rearrange column order
Columns("K:K").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("K2:K35").Formula = "=I2&""-""&J2"
Range("K2:K35").Copy
Range("I2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("J:K").Delete Shift:=xlToLeft
Columns("L:N").Cut
Columns("I:I").Insert Shift:=xlToRight
Columns("M:N").Cut
Columns("L:L").Insert Shift:=xlToRight
Columns("H:H").Cut
Columns("O:O").Insert Shift:=xlToRight
' Add division codes for each team (and corrected "Montréal")
For Each c In Range("B1:B35")
Select Case c.Text
Case "ATLANTIC", "METROPOLITAN"
Range(c.Offset(1, 15), c.Offset(8, 15)).Formula = "A"
Case "CENTRAL", "PACIFIC"
Range(c.Offset(1, 15), c.Offset(7, 15)).Formula = "C"
Case "Montreal"
c.Value = "Montréal"
End Select
Next c
' Delete unneeded headings
For i = 35 To 1 Step -1
Select Case Cells(i, 2).Text
Case "METROPOLITAN", "CENTRAL", "PACIFIC", "Western Conference"
Rows(i & ":" & i).Delete Shift:=xlUp
End Select
Next i
' Insert columns for calculated data
Columns("H:K").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("M:M").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("O:O").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("Q:Q").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("S:S").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("U:U").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("Y:Y").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Name column ranges for use in formulae
Call MakeRange("TeamNames", "B", False)
Call MakeRange("Games", "C", False)
Call MakeRange("Wins", "D", False)
Call MakeRange("Losses", "E", False)
Call MakeRange("Overtime", "F", False)
Call MakeRange("Points", "G", True)
Call MakeRange("WinPct", "H", False)
Call MakeRange("Projected", "I", False)
Call MakeRange("League_Rank", "J", False)
Call MakeRange("Playoffs", "K", False)
Call MakeRange("GoalsFor", "L", True)
Call MakeRange("GF_Rank", "M", True)
Call MakeRange("GoalsAgainst", "N", True)
Call MakeRange("GA_Rank", "O", True)
Call MakeRange("GoalDiff", "P", True)
Call MakeRange("Diff_Rank", "Q", True)
Call MakeRange("Home", "R", True)
Call MakeRange("Home_Rank", "S", True)
Call MakeRange("Away", "T", True)
Call MakeRange("Away_Rank", "U", True)
Call MakeRange("Shootout", "V", True)
Call MakeRange("ROWins", "W", True)
Call MakeRange("Last10", "X", True)
Call MakeRange("L10Change", "Y", True)
Call MakeRange("Streak", "Z", True)
Call MakeRange("Division", "AA", False)
Call MakeRange("Conference", "AB", False)
Call MakeRange("PPG", "AC", False)
Call MakeRange("WPG", "AD", False)
Call MakeRange("ROWPG", "AE", True)
Call MakeRange("GFPG", "AF", True)
Call MakeRange("GAPG", "AG", True)
Call MakeRange("DiffPG", "AH", True)
Call MakeRange("HomePPG", "AI", True)
Call MakeRange("AwayPPG", "AJ", True)
Call MakeRange("Sort", "AK", True)
Call MakeRange("L10Pts", "AL", True)
Call MakeRange("L10PPG", "AM", True)
Call MakeRange("DivRank", "AN", False)
Call MakeRange("DivSort", "AO", True)
Call MakeRange("StreakPts", "AP", True)
Call MakeRange("ConfRank", "AQ", False)
Call MakeRange("SOPct", "AR", True)
Call MakeRange("MaxPts", "AS", True)
Call MakeRange("DivMax4th", "AT", True)
Call MakeRange("PlayoffTarget", "AU", False)
Call MakeRange("PlayoffPace", "AV", False)
Call MakeRange("PlayoffLimit", "AW", False)
LastColumn = "AW"
ActiveWorkbook.Names.Add Name:="LastColumn", RefersTo:=LastColumn
ActiveWorkbook.Names.Add Name:="FormatRange", RefersTo:="=$A$2:$" & LastColumn & "$31"
ActiveWorkbook.Names.Add Name:="SortRange", RefersTo:="=$B$1:$" & LastColumn & "$31"
' Trim team names
For Each c In Range("TeamNames")
c.Value = Trim(c.Value)
If Left(c.Value, 4) = "x - " Or Left(c.Value, 4) = "y - " _
Or Left(c.Value, 4) = "z - " Or Left(c.Value, 4) = "p - " Then
c.Value = Mid(c.Value, 5, Len(c.Value))
End If
Next c
' Add formulae
' Conference position
Range("A1").Formula = "Conf"
Range("A2:A31").Formula = "=ConfRank"
' Team name
Range("B1").Formula = "Team"
' Games (in case user changes wins, losses, or OT)
Range("Games") = "=Wins+Losses+Overtime"
' Points (in case user changes wins, losses, or OT)
Range(RngCol("Points", 1)).Formula = "Pts"
Range("Points").Formula = "=Wins*2+Overtime"
' Winning %
Range(RngCol("WinPct", 1)).Formula = "Win%"
Range("WinPct").Formula = "=IF(Games=0,0,Points/Games/2)"
' Projected points for the year
Range(RngCol("Projected", 1)).Formula = "Proj"
Range("Projected").Formula = "=IF(Games=0,0,ROUND(Points/Games*AnnualGames,0))"
' League-wide order
Range(RngCol("League_Rank", 1)).Formula = "League"
Range("League_Rank").Formula = "=RANK.EQ(Sort,Sort)"
' Playoffs
Range(RngCol("Playoffs", 1)).Formula = "Playoffs"
Range("Playoffs").Formula = "=IF(OR(Points>DivMax4th,Points>IF(Conference=""W"",LARGE(MaxPts_W,9),LARGE(MaxPts_E,9))),""* IN *""," & _
"IF(MaxPts""&B2)/1000000000"
' Points over past 10 games
Range(RngCol("L10Pts", 1)).Formula = "L10Pts"
Range("L10Pts").Formula = "=VALUE(LEFT(Last10,SEARCH(""-"",Last10)-1))*2+VALUE(RIGHT(Last10,LEN(Last10)-FIND(""-"",Last10,FIND(""-"",Last10)+1)))"
' Winning % 10 games ago
Range(RngCol("L10PPG", 1)).Formula = "L10PPG"
Range("L10PPG").Formula = "=IF(Games<=10,0,(Points-L10Pts)/(Games-10))"
' Division ranking
Range(RngCol("DivRank", 1)).Formula = "DivRank"
Range("DivRank").Formula = "=SUMPRODUCT(--(AA2=Division))-SUMPRODUCT(--((AK2>Sort)*(AA2=Division)))"
' Division sort position
Range(RngCol("DivSort", 1)).Formula = "DivSort"
Range("DivSort").Formula = "=IF(DivRank<=3,10,0)+Sort"
' Points on current streak
Range(RngCol("StreakPts", 1)).Formula = "StreakPts"
Range("StreakPts").Formula = "=IF(LEFT(Streak,3)=""Won"",VALUE(SUBSTITUTE(Streak,""Won "",""""))," & _
"IF(LEFT(Streak,4)=""Lost"",-VALUE(SUBSTITUTE(Streak,""Lost "","""")),0))"
' Conference rank
Range(RngCol("ConfRank", 1)).Formula = "ConfRank"
Range("ConfRank").Formula = "=IF(Conference=""W"",RANK.EQ(DivSort_W,DivSort_W),RANK.EQ(DivSort_E,DivSort_E))"
' Shootout percentage
Range(RngCol("SOPct", 1)).Formula = "SOPct"
Range("SOPct").Formula = "=IF(Shootout=""-"",IF(MarkTop,0,1),VALUE(LEFT(Shootout,FIND(""-"",Shootout)-1))/" & _
"(VALUE(LEFT(Shootout,FIND(""-"",Shootout)-1))+VALUE(RIGHT(Shootout,LEN(Shootout)-FIND(""-"",Shootout)))))"
' Maximum points that the team can earn
Range(RngCol("MaxPts", 1)).Formula = "MaxPts"
Range("MaxPts").Formula = "=Points+(AnnualGames-Games)*2"
' Maximum points
Range(RngCol("DivMax4th", 1)).Formula = "DivMax4th"
Range(RngCol("DivMax4th", 2)).FormulaArray = "=LARGE(IF(AA2=Division,MaxPts,0),4)"
Range(RngCol("DivMax4th", 2)).Copy
Range(RngCol("DivMax4th", 3) & ":" & RngCol("DivMax4th", LastRow)).PasteSpecial xlPasteFormulas
' Playoff target percentage, i.e. who is the team trying to catch
Range(RngCol("PlayoffTarget", 1)).Formula = "PlayoffTarget"
Range(RngCol("PlayoffTarget", 2)).FormulaArray = "=IF(" & RngCol("ConfRank", 2) & "<=8,MIN(LARGE(IF(AA2=Division,Sort,0),4)," & _
"LARGE(IF(AB2=Conference,DivSort,0),9)),MIN(LARGE(IF(AA2=Division,Sort,0),3),LARGE(IF(AB2=Conference,DivSort,0),8)))"
Range(RngCol("PlayoffTarget", 2)).Copy
Range(RngCol("PlayoffTarget", 3) & ":" & RngCol("PlayoffTarget", LastRow)).PasteSpecial xlPasteFormulas
' Playoff pace, i.e. how well does the team have to do to hit its target winning %
Range(RngCol("PlayoffPace", 1)).Formula = "PlayoffPace"
Range("PlayoffPace").Formula = "=IF(Games=82,0,((82*PlayoffTarget)-Points)/(82-Games)/2)"
' Playoff limit - max of 1, min of 0
Range(RngCol("PlayoffLimit", 1)) = "PlayoffLimit"
Range("PlayoffLimit").Formula = "=IF(PlayoffPace>1,1,IF(PlayoffPace<0,0,PlayoffPace))"
' User options
With Range("A33")
.Formula = "Options"
.Font.Underline = True
End With
Call AddCheckBox("A34", "RankByLeague", cbLeagueWide, "RankByLeague")
Range("B34").Formula = "Check to show league-wide rankings; uncheck to show conference rankings"
Call AddCheckBox("A35", "PlayoffsAsPercent", cbPlayoffs, "PlayoffsAsPercent")
Range("B35").Formula = "Check to show playoff pace as a winning %; uncheck to show it as points"
Call AddCheckBox("A36", "MarkTop", cbBestWorst, "MarkTop")
Range("B36").Formula = "Check to mark the best team in each category; uncheck to show the worst"
' Rank orders for best & worst - used when highlighting best / worst teams
' Best value is highest, i.e. descending order
ActiveWorkbook.Names.Add Name:="BestIsHigh", RefersTo:="=IF(MarkTop,0,1)"
' Best value is lowest, i.e. ascending order
ActiveWorkbook.Names.Add Name:="BestIsLow", RefersTo:="=IF(MarkTop,1,0)"
' Formatting
' Set heading and column alignments
Range("A1").HorizontalAlignment = xlRight
Range("C1:" & LastColumn & "1").HorizontalAlignment = xlRight
Range("Playoffs").HorizontalAlignment = xlRight
Range(RngCol("Home") & ":" & RngCol("Home")).HorizontalAlignment = xlCenter
Range(RngCol("Away") & ":" & RngCol("Away")).HorizontalAlignment = xlCenter
Range(RngCol("Shootout") & ":" & RngCol("Shootout")).HorizontalAlignment = xlCenter
Range(RngCol("Last10") & ":" & RngCol("Last10")).HorizontalAlignment = xlCenter
Range(RngCol("Streak") & ":" & RngCol("Streak")).HorizontalAlignment = xlCenter
' Underline headings
Rows("1:1").Select
Selection.Font.Underline = xlUnderlineStyleSingle
' Set Rank columns to smaller font & italics
rng = RngCol("GF_Rank", 1) & ","
rng = rng & RngCol("GA_Rank", 1) & ","
rng = rng & RngCol("Diff_Rank", 1) & ","
rng = rng & RngCol("Home_Rank", 1) & ","
rng = rng & RngCol("Away_Rank", 1)
With Range(rng)
.HorizontalAlignment = xlRight
With .Font
.Name = "Calibri"
.Size = 9
.Italic = True
End With
End With
' Set column widths
Columns("A:A").ColumnWidth = 5
Columns("B:B").ColumnWidth = 15
Range("C:G,I:I,L:Q,S:S,U:V").ColumnWidth = 5
Range("H:H,R:R,T:T,W:W,X:X").ColumnWidth = 6
Range("Z:Z").ColumnWidth = 7
Columns("J:K").EntireColumn.AutoFit
Columns("Y:Y").EntireColumn.AutoFit
If WorksheetFunction.Min(Range("Games")) < 10 Then
Columns("X:Y").EntireColumn.Hidden = True
End If
' Heavy line between West and East
If WestAtTop Then
rng = "A15:" & LastColumn & "15"
Else
rng = "A17:" & LastColumn & "17"
End If
With Range(rng).Borders(xlEdgeBottom)
.LineStyle = xlDashDotDot
.Color = RGB(255, 0, 0)
.Weight = xlMedium
End With
' Light line between 4th & 5th place teams
If WestAtTop Then
rng = "A9:" & LastColumn & "9,A23:" & LastColumn & "23"
Else
rng = "A9:" & LastColumn & "9,A25:" & LastColumn & "25"
End If
With Range(rng).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = 0
.Weight = xlThin
End With
' Light line between halves of out-of-playoffs teams
If WestAtTop Then
rng = "A5:" & LastColumn & "5,A12:" & LastColumn & "12,A19:" & LastColumn & "19,A27:" & LastColumn & "27"
Else
rng = "A5:" & LastColumn & "5,A13:" & LastColumn & "13,A21:" & LastColumn & "21,A28:" & LastColumn & "28"
End If
With Range(rng).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = 0
.Weight = xlHairline
End With
' Vertical dividing lines
With Range("Points," & _
"Projected," & _
"League_Rank," & _
"Playoffs," & _
"GF_Rank," & _
"GA_Rank," & _
"Diff_Rank," & _
"Home_Rank," & _
"Away_Rank," & _
"ROWins," & _
"L10Change" _
).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = RGB(128, 128, 128)
.Weight = xlHairline
End With
' Number formats
Range("WinPct").NumberFormat = "0.000"
Range("L10Change").NumberFormat = "+ 0;- 0;""-""??_)"
' Background colours - conditional formatting
' Headings
Range("A1:" & LastColumn & "1").Interior.Color = cHeadings
' Clear any existing conditional formatting
Range("FormatRange").Select
Cells.FormatConditions.Delete
' Teams in playoffs
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=IF(" & RngCol("Conference", 2, True) & "=""W"",RANK.EQ(" & RngCol("DivSort", 2, True, False) & ",DivSort_W)<=8,RANK.EQ(" & RngCol("DivSort", 2, True, False) & ",DivSort_E)<=8)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Interior.Color = cInPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Teams out of playoffs
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=IF(" & RngCol("Conference", 2, True) & "=""W"",RANK.EQ(" & RngCol("DivSort", 2, True, False) & ",DivSort_W)>8,RANK.EQ(" & RngCol("DivSort", 2, True, False) & ",DivSort_E)>8)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Interior.Color = cOutOfPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' League-wide order - to highlight non-playoff teams in the top 16
Range("League_Rank").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=(J2>16)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Interior.Color = cOutOfPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' League-wide order - to highlight playoff teams out of the top 16
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=(J2<=16)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Interior.Color = cInPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Team names - to highlight teams that are only in the top 6 due to division order, but still in top 8
Range("TeamNames").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=IF(" & RngCol("Conference", 2, True) & "=""W"",AND(RANK.EQ(" & RngCol("DivSort", 2, True, False) & ",DivSort_W)<=6,RANK.EQ(AK2,Sort_W)>6)," & _
"AND(RANK.EQ(" & RngCol("DivSort", 2, True, False) & ",DivSort_E)<=6,RANK.EQ(" & RngCol("Sort", 2, True, False) & ",Sort_E)>6))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Interior.Color = cDivisionQual
Selection.FormatConditions(1).StopIfTrue = False
' Team names - to highlight teams that are only in the top 6 due to division order, but not in top 8
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=IF(" & RngCol("Conference", 2, True) & "=""W"",AND(RANK.EQ(" & RngCol("DivSort", 2, True, False) & ",DivSort_W)<=8,RANK.EQ(AK2,Sort_W)>8)," & _
"AND(RANK.EQ(" & RngCol("DivSort", 2, True, False) & ",DivSort_E)<=8,RANK.EQ(" & RngCol("Sort", 2, True, False) & ",Sort_E)>8))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Interior.Color = cOutOfPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Playoff pace is 0 - should have enough points to be in
Range("Playoffs").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=OR(" & RngCol("PlayoffLimit", 2) & "=0," & RngCol("Playoffs", 2) & "=""in ?"")"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.5
.Gradient.RectangleRight = 0.5
.Gradient.RectangleTop = 0.5
.Gradient.RectangleBottom = 0.5
.Gradient.ColorStops.Clear
End With
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0).Color = cInPlayoffs
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1).Color = cInPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Playoff pace is 1 - not in control of their own destiny
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=OR(" & RngCol("PlayoffLimit", 2) & "=1," & RngCol("Playoffs", 2) & "=""out ?"")"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.5
.Gradient.RectangleRight = 0.5
.Gradient.RectangleTop = 0.5
.Gradient.RectangleBottom = 0.5
.Gradient.ColorStops.Clear
End With
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0).Color = cOutOfPlayoffs
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1).Color = cOutOfPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Confirmed out of playoffs
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=(" & RngCol("Playoffs", 2) & "=""out"")"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.1
.Gradient.RectangleRight = 0.9
.Gradient.RectangleTop = 0.1
.Gradient.RectangleBottom = 0.9
.Gradient.ColorStops.Clear
End With
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0).Color = cOutOfPlayoffs
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1).Color = cOutOfPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Confirmed in playoffs
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=(" & RngCol("Playoffs", 2) & "=""* in *"")"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.1
.Gradient.RectangleRight = 0.9
.Gradient.RectangleTop = 0.1
.Gradient.RectangleBottom = 0.9
.Gradient.ColorStops.Clear
End With
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0).Color = cInPlayoffs
Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1).Color = cInPlayoffPos
Selection.FormatConditions(1).StopIfTrue = False
' Mark best & worst in different categories
Call BestWorstRank("GoalsFor", "GF_Rank")
Call BestWorstRank("GoalsAgainst", "GA_Rank")
Call BestWorstRank("GoalDiff", "Diff_Rank")
Call BestWorstRank("Home", "Home_Rank")
Call BestWorstRank("Away", "Away_Rank")
Call BestWorstData("Shootout", "SOPct")
Call BestWorstData("ROWins", "ROWPG")
Call BestWorstData("Last10", "L10Pts")
Call BestWorstData("L10Change", "L10Change")
Call BestWorstData("Streak", "StreakPts")
' Highlight teams selected by the user for highlighting
Range("FormatRange").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=IF(NOT(ISBLANK(VLOOKUP($B2,TeamHighlights,2,FALSE))),TRUE,FALSE)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
If ReverseBold Then
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = True
.Color = FontHighlight.Color
End With
Else
With Selection.FormatConditions(1).Font
.Bold = FontHighlight.Bold
.Italic = FontHighlight.Italic
.Color = FontHighlight.Color
End With
End If
Selection.FormatConditions(1).StopIfTrue = False
' Hide calculation columns
If Not ShowWork Then
Range("AA:" & LastColumn).EntireColumn.Hidden = True
End If
' Reference cell for sort button and explanatory notes
Set cl = Range("A36")
' Add Re-Sort command button
ActiveSheet.Buttons.Add(cl.Offset(2, 0).Left, cl.Offset(2, 0).Top, _
cl.Offset(3, 2).Left - cl.Offset(2, 0).Left, cl.Offset(3, 2).Top - cl.Offset(1, 0).Top).Select
Selection.OnAction = "'" & ThisWorkbook.Name & "'!SortData"
Selection.Characters.Text = "Re-Sort Standings"
With Selection.Characters(Start:=1, Length:=17).Font
.Name = FontDefault.Name
.FontStyle = "Regular"
.Size = FontDefault.Size
.Underline = xlUnderlineStyleNone
End With
' Add explanatory notes
cl.Offset(5, 1).Select
Selection.Formula = "Columns"
Selection.Offset(1, 0).Formula = "Proj"
Selection.Offset(1, 1).Formula = "Projected year-end points based on current winning %"
Selection.Offset(2, 0).Formula = "Overall "
Selection.Offset(2, 1).Formula = "The team's league-wide ranking based on current winning %"
Selection.Offset(3, 0).Formula = "Playoffs "
Selection.Offset(3, 1).Formula = "How well a team in the top 8 has to play for the rest of the year to finish ahead of the 9th place team at the 9th"
Selection.Offset(4, 1).Formula = "place team's current pace, and how well a team in the bottom 7 has to play for the rest of the year to finish ahead"
Selection.Offset(5, 1).Formula = "of the 8th place team at the 8th place team's current pace"
Selection.Offset(6, 0).Formula = "GF"
Selection.Offset(6, 1).Formula = "Goals For"
Selection.Offset(7, 0).Formula = "GA"
Selection.Offset(7, 1).Formula = "Goals Against"
Selection.Offset(8, 0).Formula = "Diff"
Selection.Offset(8, 1).Formula = "Difference between Goals For and Goals Against (highlighted on a per-game basis)"
If Application.WorksheetFunction.Min(Range("Games")) > 10 Then
Selection.Offset(9, 0).Formula = "L10"
Selection.Offset(9, 1).Formula = "Record over Last 10 Games"
Selection.Offset(10, 0).Formula = "L10 Chg"
Selection.Offset(10, 1).Formula = "The change in the team's conference or league-wide rank over the past 10 games"
Selection.Offset(11, 0).Formula = "ROW"
Selection.Offset(11, 1).Formula = "Regulation and Overtime Wins"
Else
Selection.Offset(9, 0).Formula = "ROW"
Selection.Offset(9, 1).Formula = "Regulation and Overtime Wins"
End If
Selection.Font.Underline = xlUnderlineStyleSingle
Range(Selection.Offset(1, 0), Selection.Offset(11, 0)).Font.Italic = True
Range(Selection.Offset(1, 0), Selection.Offset(11, 0)).NumberFormat = "@*."
' Unprotect columns where a user could reasonably enter changes
rng = "Wins,Losses,Overtime,GoalsFor,GoalsAgainst,ROWins"
Range(rng).Locked = False
' Highlight headings of editable columns
rng = RngCol("Wins", 1) & "," & RngCol("Losses", 1) & "," & RngCol("Overtime", 1) & "," & _
RngCol("GoalsFor", 1) & "," & RngCol("GoalsAgainst", 1) & "," & RngCol("ROWins", 1)
With Range(rng)
.Font.Bold = True
.Font.Underline = xlUnderlineStyleDouble
End With
Call SortData(False)
' Finish gracefully - select top, left of lower-right pane; turn on screen updating
Application.ScreenUpdating = True
Cells(ActiveWindow.SplitRow + 1, ActiveWindow.SplitColumn + 1).Select
End Sub
Sub SortData(Optional Updating = True)
'
' Unprotect the sheet and suppress screen updates (to reduce flickering)
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
Application.ScreenUpdating = False
Range("A1").Select ' bring full list into view
Range("SortRange").Select
ActiveWorkbook.Worksheets("Standings").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Standings").Sort.SortFields.Add Key:=Range( _
"Conference"), SortOn:=xlSortOnValues, Order:=ConfSort, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Standings").Sort.SortFields.Add Key:=Range( _
"DivSort"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Standings").Sort
.SetRange Range("SortRange")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
If Updating Then
Application.ScreenUpdating = True
End If
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("C2").Select
End Sub