[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT]
[FONT=Courier New][SIZE=1]Sub MakeGrid()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT]
[FONT=Courier New][SIZE=1] Dim ws As Worksheet
Dim iLastRow As Long
Dim iRow As Long
Dim iCol As Long
Dim iRound As Integer
Dim iStep As Integer
[COLOR=green] ' set up a reference to the correct worksheet and count how many competitors
[/COLOR] Set ws = ThisWorkbook.Sheets("Sheet1")
iLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
[COLOR=green] ' make sure there are no merged cells
[/COLOR] ws.Columns("B").MergeCells = False
[COLOR=green] ' fill column B with random numbers and hide all the competitors' names
[/COLOR] ws.Range("B2") = "=RAND()"
ws.Range("B2").AutoFill Destination:=Range("B2:B" & CStr(iLastRow))
ws.Range("A2:A" & CStr(iLastRow)).Font.Color = vbWhite
[COLOR=green] ' sort the competitors using the randomly-generated numbers as the sort key
[/COLOR] With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B2:B" & CStr(iLastRow)), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A2:B" & CStr(iLastRow))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
[COLOR=green] ' delete the random numbers as we don't need them any more
[/COLOR] ws.Range("B2:B" & CStr(iLastRow)).ClearContents
[COLOR=green] ' the LOG(2) function converts the number of competitors into the number of rounds
' required to complete a knock-out competition
[/COLOR] iCol = WorksheetFunction.Log(iLastRow - 1, 2)
[COLOR=green] ' the number of rounds to the power of 2 gives us the size of the grid
[/COLOR] iRow = 2 ^ iCol
[COLOR=green] ' whatever format the user has chosen for the column A heading, copy that to all of
' the columns we're using
[/COLOR] ws.Range("A1").Copy
ws.Cells(1, 2).Resize(1, iCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] ' place borders around the column headers
With ws.Cells(1, 2).Resize(1, iCol)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[COLOR=green] ' we use 2 to the power of the round number to decide how many cells are going to be[/COLOR][/SIZE][/FONT]
[FONT=Courier New][SIZE=1][COLOR=green] ' merged to contain the name of the winner of the previous round, i.e. in round 2 the[/COLOR][/SIZE][/FONT]
[FONT=Courier New][SIZE=1][COLOR=green] ' boxes are 2^1 = 2 cells, in round 3 the boxes are 2^2 = 4 cells, etc
[/COLOR] For iRound = 0 To iCol
ws.Cells(1, iRound + 1) = "Round " & CStr(iRound + 1)
For iStep = 2 To iRow Step (2 ^ iRound)
With ws.Cells(iStep, iRound + 1).Resize(2 ^ iRound, 1)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = False
.Merge
End With
Next iStep
Next iRound
ws.Cells(1, iCol) = "Semi-Final"
ws.Cells(1, iCol + 1) = "Final"
ws.Range("A1").Select
Application.ScreenUpdating = True
[COLOR=green]' ready to display the results of the draw
[/COLOR]
MsgBox "There are " & CStr(iLastRow - 1) & " competitors" & Space(10) & vbCrLf & vbCrLf _
& "Click OK to start draw . . ." & Space(10), vbOKOnly + vbInformation
For iStep = 2 To iLastRow
[COLOR=green]' keep the current worksheet row visible on the screen
[/COLOR] ActiveWindow.ScrollRow = IIf(iStep <= 20, 1, iStep - 20)
ws.Cells(iStep, 1).Font.Color = vbBlack
If iStep Mod 2 = 0 Then
[COLOR=green] ' it's a 'home' competitor but the 'away' cells below it is empty, so it's a 'bye'
[/COLOR] If IsEmpty(ws.Cells(iStep + 1, 1)) Then
MsgBox ws.Cells(iStep, 1).Value & " gets a bye in the first round" & Space(10), _
vbOKOnly + vbInformation
Else
[COLOR=green]' it's a 'home' competitor and the 'away' cells has a name in it
[/COLOR] MsgBox ws.Cells(iStep, 1).Value & " will be playing . . ." & Space(10), _
vbOKOnly + vbInformation
End If
Else
[COLOR=green] ' it's an 'away' competitor
[/COLOR] MsgBox ". . . " & ws.Cells(iStep, 1).Value & Space(10), _
vbOKOnly + vbInformation
End If
Next iStep
ActiveWindow.ScrollRow = 1
MsgBox "All competitors allocated" & Space(10), vbOKOnly + vbInformation
End Sub[/SIZE][/FONT]
