Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.
Become a Premium Member and unlock a new, free course in leading technologies each month.
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Private Sub CommandButton1_Click()
Dim intIndex As Integer
Dim intIndex2 As Integer
Dim intLastRow As Range
Dim intTics() As Integer
Dim intRow As Integer 'The row number in which to display the player's name whose turn it is
Dim intRnd() As Integer
Randomize
' Get the number of the last row with data in it
Set intLastRow = Range("A1").End(xlDown).Offset(0, 0)
' Fill an array with the tickets each person has
ReDim intTics(1 To intLastRow.Row)
For intIndex = 1 To intLastRow.Row
intTics(intIndex) = Range("B" & intIndex).Value
Next
' Fill an array with the numbers 2 to however many players there are. This array will be shuffled
' so that players 2 through n can be chosen in a random fashion
ReDim intRnd(intLastRow.Row - 2)
For intIndex = 0 To intLastRow.Row - 2
intRnd(intIndex) = intIndex + 2
Next
Do Until intTics(1) = 0
' call the routine that shuffles the array
ShuffleArray intRnd
For intIndex = 1 To intLastRow.Row
If intIndex = 1 Then
' At the start of a round (indicated by intIndex being = 1), display the
' player name with the most tickets. That player name is assumed to be in A1
intRow = intRow + 1
Range("D" & (intRow)).Value = Range("A" & intIndex).Value
' Decrement the player's number of tickets by 1
intTics(intIndex) = intTics(intIndex) - 1
Else
' For the rest use the intRnd array as an index into intTics
For intIndex2 = 0 To UBound(intRnd)
If intTics(intRnd(intIndex2)) > 0 Then
intRow = intRow + 1
Range("D" & (intRow)).Value = Range("A" & intRnd(intIndex2)).Value
intTics(intRnd(intIndex2)) = intTics(intRnd(intIndex2)) - 1
End If
Next
Exit For
End If
Next
Loop
End Sub
Private Sub ShuffleArray(pvarArray As Variant)
'Knuth untyped shuffle
Dim i As Long
Dim iMin As Long
Dim iMax As Long
Dim lngReplace As Long
Dim varSwap As Variant
iMin = LBound(pvarArray)
iMax = UBound(pvarArray)
For i = iMax To iMin + 1 Step -1
lngReplace = Int((i - iMin + 1) * Rnd + iMin)
varSwap = pvarArray(i)
pvarArray(i) = pvarArray(lngReplace)
pvarArray(lngReplace) = varSwap
Next
End Sub
Dim intIndex As Integer
Dim intIndex2 As Integer
Dim intLastRow As Range
Dim intTics() As Integer
Dim intRow As Integer 'The row number in which to display the player's name whose turn it is
Dim strLeftOver() As String
Dim intTickets As Integer
Dim intStep As Integer
Dim intTicsLeft As Integer
Dim intNext As Integer
Randomize
' Get the number of the last row with data in it
Set intLastRow = Range("A1").End(xlDown).Offset(0, 0)
' Fill an array with the tickets each person has
ReDim intTics(1 To intLastRow.Row)
For intIndex = 1 To intLastRow.Row
intTics(intIndex) = Range("B" & intIndex).Value
intTickets = intTickets + Range("B" & intIndex).Value
Next
intTicsLeft = intTickets
For intIndex = 1 To intLastRow.Row
' Evenly distribute a players name in the list depending on how many tickets
' he has. This is done by dividing the total tickets by the tickets he has and
' using the result to determine the spacing between his names in the list. Before
' we can do that however the result needs to be rounded up so that the steps are
' whole numbers. Rounding down would result in the player showing up too many times.
' Rounding up results in the player showing up too few times but we can handle that.
intStep = RoundUp(intTickets / intTics(intIndex))
' intRow is the number of the row where the name will be displayed
intRow = intIndex
For intIndex2 = 1 To intTickets Step intStep
' Make sure the row isn't occupied
Do Until Range("D" & intRow).Value = ""
intRow = intRow + 1
Loop
' Check to make sure we haven't gone too far
If intRow <= intTickets Then
' Write the value
Range("D" & intRow).Value = Range("A" & intIndex).Value
' Decrement the player's number of tickets by 1
intTics(intIndex) = intTics(intIndex) - 1
' Decrement the numbver of tickets left (used later)
intTicsLeft = intTicsLeft - 1
' Increment the row
intRow = intRow + intStep
End If
Next
Next
' After doing the above there will be some picks left over and a matching number of blank rows.
' We'll now create an array containing the player names associated with those picks.
ReDim strLeftOver(1 To intTicsLeft)
intNext = 1
For intIndex = 1 To intLastRow.Row
For intIndex2 = 1 To intTics(intIndex)
strLeftOver(intNext) = Range("A" & intIndex).Value
intNext = intNext + 1
Next
Next
' Shuffle the remaining names
ShuffleArray strLeftOver
' Finally fill in the blank rows using the shuffled values
intNext = 1
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
Range("D" & intRow).Value = strLeftOver(intNext)
intNext = intNext + 1
End If
Next
Dim intIndex As Integer
Dim intIndex2 As Integer
Dim intLastRow As Range
Dim intTics() As Integer
Dim intRow As Integer 'The row number in which to display the player's name whose turn it is
Dim strLeftOver() As String
Dim intTickets As Integer
Dim intStep As Integer
Dim intTicsLeft As Integer
Dim intNext As Integer
Randomize
' Get the number of the last row with data in it
Set intLastRow = Range("A1").End(xlDown).Offset(0, 0)
' Fill an array with the tickets each person has
ReDim intTics(1 To intLastRow.Row)
For intIndex = 1 To intLastRow.Row
intTics(intIndex) = Range("B" & intIndex).Value
intTickets = intTickets + Range("B" & intIndex).Value
Next
intTicsLeft = intTickets
' In the first round, each person gets a pick
For intIndex = 1 To intLastRow.Row
Range("D" & intIndex).Value = Range("A" & intIndex).Value
intTics(intIndex) = intTics(intIndex) - 1
intTicsLeft = intTicsLeft - 1
Next
For intIndex = 1 To intLastRow.Row
' Evenly distribute a players name in the list depending on how many tickets
' he has. This is done by dividing the total tickets by the tickets he has left and
' using the result to determine the spacing between his names in the list. Before
' we can do that however the result needs to be rounded up so that the steps are
' whole numbers. Rounding down would result in the player showing up too many times.
' Rounding up results in the player showing up too few times but we can handle that.
intStep = RoundUp(intTickets / intTics(intIndex))
' intRow is the number of the row where the name will be displayed
' aand we add intLastRow.Row because we filled some rows in tghe first round code above
intRow = intIndex + intLastRow.Row
For intIndex2 = 1 To intTickets Step intStep
' Make sure the row isn't occupied
Do Until Range("D" & intRow).Value = ""
intRow = intRow + 1
Loop
' Check to make sure we haven't gone too far
If intRow <= intTickets Then
' Write the value
Range("D" & intRow).Value = Range("A" & intIndex).Value
' Decrement the player's number of tickets by 1
intTics(intIndex) = intTics(intIndex) - 1
' Decrement the numbver of tickets left (used later)
intTicsLeft = intTicsLeft - 1
' Increment the row
intRow = intRow + intStep
End If
Next
Next
' After doing the above there will be some picks left over and a matching number of blank rows.
' We'll now create an array containing the player names associated with those picks.
ReDim strLeftOver(1 To intTicsLeft)
intNext = 1
For intIndex = 1 To intLastRow.Row
For intIndex2 = 1 To intTics(intIndex)
strLeftOver(intNext) = Range("A" & intIndex).Value
intNext = intNext + 1
Next
Next
' Shuffle the remaining names
ShuffleArray strLeftOver
' Finally fill in the blank rows using the shuffled values
intNext = 1
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
Range("D" & intRow).Value = strLeftOver(intNext)
intNext = intNext + 1
End If
Next
Dim intIndex As Integer
Dim intIndex2 As Integer
Dim intLastRow As Range
Dim intTics() As Integer
Dim intRow As Integer 'The row number in which to display the player's name whose turn it is
Dim strLeftOver() As String
Dim intTickets As Integer
Dim intStep As Integer
Dim intTicsLeft As Integer
Dim intNext As Integer
Randomize
' Get the number of the last row with data in it
Set intLastRow = Range("A1").End(xlDown).Offset(0, 0)
' Fill an array with the tickets each person has
ReDim intTics(1 To intLastRow.Row)
For intIndex = 1 To intLastRow.Row
intTics(intIndex) = Range("B" & intIndex).Value
intTickets = intTickets + Range("B" & intIndex).Value
Next
intTicsLeft = intTickets
' In the first round, each person gets a pick
For intIndex = 1 To intLastRow.Row
Range("D" & intIndex).Value = Range("A" & intIndex).Value
intTics(intIndex) = intTics(intIndex) - 1
intTicsLeft = intTicsLeft - 1
Next
For intIndex = 1 To intLastRow.Row
' Evenly distribute a players name in the list depending on how many tickets
' he has. This is done by dividing the total tickets by the tickets he has left and
' using the result to determine the spacing between his names in the list. Before
' we can do that however the result needs to be rounded up so that the steps are
' whole numbers. Rounding down would result in the player showing up too many times.
' Rounding up results in the player showing up too few times but we can handle that.
If intTics(intIndex) > 0 Then
intStep = RoundUp(intTicsLeft / intTics(intIndex))
' intRow is the number of the row where the name will be displayed
' and we add intLastRow.Row because we filled some rows in the first round code above
intRow = intIndex + intLastRow.Row
For intIndex2 = 1 To intTickets Step intStep
' Make sure the row isn't occupied
Do Until Range("D" & intRow).Value = ""
intRow = intRow + 1
Loop
' Check to make sure we haven't gone too far
If intRow <= intTickets Then
' Write the value
Range("D" & intRow).Value = Range("A" & intIndex).Value
' Decrement the player's number of tickets by 1
intTics(intIndex) = intTics(intIndex) - 1
' Decrement the number of tickets left (used later)
'new
'intTicsLeft = intTicsLeft - 1
' Increment the row
intRow = intRow + intStep
End If
Next
End If
Next
' After doing the above there will be some picks left over and a matching number of blank rows.
' We'll now create an array containing the player names associated with those picks.
' First count the remaining pics
intTicsLeft = 0
For intIndex = 1 To intLastRow.Row
intTicsLeft = intTicsLeft + intTics(intIndex)
Next
ReDim strLeftOver(1 To intTicsLeft)
' Create the array
intNext = 1
For intIndex = 1 To intLastRow.Row
For intIndex2 = 1 To intTics(intIndex)
strLeftOver(intNext) = Range("A" & intIndex).Value
intNext = intNext + 1
Next
Next
' Shuffle the remaining names
ShuffleArray strLeftOver
' Finally fill in the blank rows using the shuffled values
intNext = 1
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
Range("D" & intRow).Value = strLeftOver(intNext)
intNext = intNext + 1
End If
Next
Private Sub CommandButton1_Click()
Dim intIndex As Integer
Dim intIndex2 As Integer
Dim intLastRow As Range
Dim intTics() As Integer
Dim intRow As Integer 'The row number in which to display the player's name whose turn it is
Dim strLeftOver() As String
Dim intTickets As Integer
Dim intStep As Integer
Dim intTicsLeft As Integer
Dim intNext As Integer
Dim bFound As Boolean
' Get the number of the last row with data in it
Set intLastRow = Range("A1").End(xlDown).Offset(0, 0)
' Fill an array with the tickets each person has
ReDim intTics(1 To intLastRow.Row)
For intIndex = 1 To intLastRow.Row
intTics(intIndex) = Range("B" & intIndex).Value
intTickets = intTickets + Range("B" & intIndex).Value
Next
intTicsLeft = intTickets
' In the first round, each person gets a pick
For intIndex = 1 To intLastRow.Row
Range("D" & intIndex).Value = Range("A" & intIndex).Value
intTics(intIndex) = intTics(intIndex) - 1
intTicsLeft = intTicsLeft - 1
Next
For intIndex = 1 To intLastRow.Row
' Evenly distribute a players name in the list depending on how many tickets
' he has. This is done by dividing the total tickets by the tickets he has left and
' using the result to determine the spacing between his names in the list. Before
' we can do that however the result needs to be rounded up so that the steps are
' whole numbers. Rounding down would result in the player showing up too many times.
' Rounding up results in the player showing up too few times but we can handle that.
If intTics(intIndex) > 0 Then
intStep = RoundUp(intTicsLeft / intTics(intIndex))
' intRow is the number of the row where the name will be displayed
' and we add intLastRow.Row because we filled some rows in the first round code above
intRow = intIndex + intLastRow.Row
For intIndex2 = 1 To intTickets Step intStep
' Make sure the row isn't occupied
Do Until Range("D" & intRow).Value = ""
intRow = intRow + 1
Loop
' Check to make sure we haven't gone too far
If intRow <= intTickets Then
' Write the value
Range("D" & intRow).Value = Range("A" & intIndex).Value
' Decrement the player's number of tickets by 1
intTics(intIndex) = intTics(intIndex) - 1
' Increment the row
intRow = intRow + intStep
End If
Next
End If
Next
' After doing the above there will be some picks left over and a matching number of blank rows.
' We'll now create an array containing the player names associated with those picks.
' First count the remaining pics
intTicsLeft = 0
For intIndex = 1 To intLastRow.Row
intTicsLeft = intTicsLeft + intTics(intIndex)
Next
ReDim strLeftOver(1 To intTicsLeft)
' Create the array
intNext = 1
For intIndex = 1 To intLastRow.Row
For intIndex2 = 1 To intTics(intIndex)
strLeftOver(intNext) = Range("A" & intIndex).Value
intNext = intNext + 1
Next
Next
' Now find the best row for the remaining names
For intNext = 1 To intTicsLeft
bFound = False
' Check to see if there's an empty row where this player's name does not appear
' in either the two rows above or the two rows below the empty row.
If FindBest(strLeftOver(intNext), intTickets) Then
bFound = True
End If
If Not bFound Then
' Couldn't find one so see if there's a row where this player's name does
' not appear in the row directly above or below the empty row.
If FindNextBest(strLeftOver(intNext), intTickets) Then
bFound = True
End If
End If
If Not bFound Then
' There's no good spot so find the 1st empty row
FindFirstEmpty strLeftOver(intNext), intTickets
End If
Next
End Sub
Private Function FindBest(strName As String, intTickets As Integer) As Boolean
Dim intRow As Integer
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
' Check to see if there's an empty row where this player's name does not appear
' in either the two rows above or the two rows below the empty row.
If Range("D" & intRow - 1).Value <> strName And _
Range("D" & intRow - 2).Value <> strName And _
Range("D" & intRow + 1).Value <> strName And intRow + 1 <= intTickets And _
Range("D" & intRow + 2).Value <> strName And intRow + 2 <= intTickets Then
Range("D" & intRow).Value = strName
FindBest = True
Exit For
End If
End If
Next
End Function
Private Function FindNextBest(strName As String, intTickets As Integer) As Boolean
Dim intRow As Integer
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
' Check to see if there's an empty row where this player's name does does
' not appear in the row directly above or below the empty row.
If Range("D" & intRow - 1).Value <> strName And _
Range("D" & intRow + 1).Value <> strName And intRow + 1 <= intTickets Then
Range("D" & intRow).Value = strName
FindNextBest = True
Exit For
End If
End If
Next
End Function
Private Sub FindFirstEmpty(strName As String, intTickets As Integer)
Dim intRow As Integer
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
Range("D" & intRow).Value = strName
Exit For
End If
Next
End Sub
Function RoundUp(ByVal X As Double) As Double
Dim Temp As Double
Temp = Int(X)
RoundUp = Temp + IIf(X = Temp, 0, 1)
End Function
Private Sub CommandButton1_Click()
Dim intIndex As Integer
Dim intIndex2 As Integer
Dim intLastRow As Range
Dim intTics() As Integer
Dim intRow As Integer 'The row number in which to display the player's name whose turn it is
Dim strLeftOver() As String
Dim intTickets As Integer
Dim intStep As Integer
Dim intTicsLeft As Integer
Dim intNext As Integer
Dim bFound As Boolean
' Get the number of the last row with data in it
Set intLastRow = Range("A1").End(xlDown).Offset(0, 0)
' Fill an array with the tickets each person has
ReDim intTics(1 To intLastRow.Row)
For intIndex = 1 To intLastRow.Row
intTics(intIndex) = Range("B" & intIndex).Value
intTickets = intTickets + Range("B" & intIndex).Value
Next
intTicsLeft = intTickets
' In the first round, each person gets a pick
For intIndex = 1 To intLastRow.Row
Range("D" & intIndex).Value = Range("A" & intIndex).Value
intTics(intIndex) = intTics(intIndex) - 1
intTicsLeft = intTicsLeft - 1
Next
For intIndex = 1 To intLastRow.Row
' Evenly distribute a players name in the list depending on how many tickets
' he has. This is done by dividing the total tickets by the tickets he has left and
' using the result to determine the spacing between his names in the list. Before
' we can do that however the result needs to be rounded up so that the steps are
' whole numbers. Rounding down would result in the player showing up too many times.
' Rounding up results in the player showing up too few times but we can handle that.
If intTics(intIndex) > 0 Then
intStep = RoundUp(intTicsLeft / intTics(intIndex))
' intRow is the number of the row where the name will be displayed
' and we add intLastRow.Row because we filled some rows in the first round code above
intRow = intIndex + intLastRow.Row
For intIndex2 = 1 To intTickets Step intStep
' Make sure the row isn't occupied
Do Until Range("D" & intRow).Value = ""
intRow = intRow + 1
Loop
' Check to make sure we haven't gone too far
If intRow <= intTickets Then
' Write the value
Range("D" & intRow).Value = Range("A" & intIndex).Value
' Decrement the player's number of tickets by 1
intTics(intIndex) = intTics(intIndex) - 1
' Increment the row
intRow = intRow + intStep
End If
Next
End If
Next
' After doing the above there will be some picks left over and a matching number of blank rows.
' We'll now create an array containing the player names associated with those picks.
' First count the remaining pics
intTicsLeft = 0
For intIndex = 1 To intLastRow.Row
intTicsLeft = intTicsLeft + intTics(intIndex)
Next
ReDim strLeftOver(1 To intTicsLeft)
' Create the array
intNext = 1
For intIndex = 1 To intLastRow.Row
For intIndex2 = 1 To intTics(intIndex)
strLeftOver(intNext) = Range("A" & intIndex).Value
intNext = intNext + 1
Next
Next
' Find the best row for the remaining picks
For intNext = 1 To intTicsLeft
FindBest strLeftOver(intNext), intTickets
Next
End Sub
Private Sub FindBest(strName As String, intTickets As Integer)
Dim intRow As Integer
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
' Check to see if there's an empty row where this player's name does not appear
' in either the four rows above or the four rows below the empty row.
If Range("D" & intRow - 1).Value <> strName And _
Range("D" & intRow - 2).Value <> strName And _
Range("D" & intRow - 3).Value <> strName And _
Range("D" & intRow - 4).Value <> strName And _
Range("D" & intRow + 1).Value <> strName And intRow + 1 <= intTickets And _
Range("D" & intRow + 2).Value <> strName And intRow + 2 <= intTickets And _
Range("D" & intRow + 3).Value <> strName And intRow + 3 <= intTickets And _
Range("D" & intRow + 4).Value <> strName And intRow + 4 <= intTickets Then
Range("D" & intRow).Value = strName
Exit Sub
End If
End If
Next
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
' Check to see if there's an empty row where this player's name does not appear
' in either the three rows above or the three rows below the empty row.
If Range("D" & intRow - 1).Value <> strName And _
Range("D" & intRow - 2).Value <> strName And _
Range("D" & intRow - 3).Value <> strName And _
Range("D" & intRow + 1).Value <> strName And intRow + 1 <= intTickets And _
Range("D" & intRow + 2).Value <> strName And intRow + 2 <= intTickets And _
Range("D" & intRow + 3).Value <> strName And intRow + 3 <= intTickets Then
Range("D" & intRow).Value = strName
Exit Sub
End If
End If
Next
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
' Check to see if there's an empty row where this player's name does not appear
' in either the two rows above or the two rows below the empty row.
If Range("D" & intRow - 1).Value <> strName And _
Range("D" & intRow - 2).Value <> strName And _
Range("D" & intRow + 1).Value <> strName And intRow + 1 <= intTickets And _
Range("D" & intRow + 2).Value <> strName And intRow + 2 <= intTickets Then
Range("D" & intRow).Value = strName
Exit Sub
End If
End If
Next
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
' Check to see if there's an empty row where this player's name does does
' not appear in the row directly above or below the empty row.
If Range("D" & intRow - 1).Value <> strName And _
Range("D" & intRow + 1).Value <> strName And intRow + 1 <= intTickets Then
Range("D" & intRow).Value = strName
Exit Sub
End If
End If
Next
For intRow = 1 To intTickets
If Range("D" & intRow).Value = "" Then
Range("D" & intRow).Value = strName
Exit Sub
End If
Next
End Sub
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.