# Determining the order of a list based on a number

Hopefully my explanation is better than the Title. I apologize for it's lack of clarity.

Here is what I'm trying to do.
Every year where do a baseball ticket draft. Whereas we split up the number of tickets, in this case 81, and each person gets a chance to pick a game that they like.

The problem here is that everyone does not get the same number of tickets so just doing a simple repeating list won't work.

What I would like to figure out how to do is input each persons name and the amount of tickets they have and then just have the excel spreadsheet go ahead and assign the slots properly.

The only caveat is that each person gets a pick in the first round.

Here is my list of people and their ticket #'s

Mike        21
Josh        16
Drew  15
Bill         10
Matt         9
Todd         8

The first round would be in the order above.
The second and following rounds would need to be split up. i.e. mike would get a pick roughly every 4 picks whereas Matt would only get a pick every 9 picks.

Does that make sense?

Is this doable? I don't even know where to start.

Thanks

Josh
###### Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Older than dirtCommented:
Are these real tickets?
To baseball games?
How are the total number of tickets decided?
How are the individual number of tickets decided?
What do you mean by "each person gets a chance to pick a game that they like"?
Author Commented:
MartinLiss, I think most of those details are irrelevant and we'll get caught up in the minutia of the question.

Basically take it down to a person and a number. The total number is 81 and each person gets a pick in the first round which brings down the total number to 75.

The question is how do we break down the remaining 75 picks, via a macro I presume, to space out each persons numbers evenly.

Does that make sense?

Thanks for the help
Older than dirtCommented:
Okay but there has to be more to it than that because I could interpret "evenly" to mean that 3 people get 13 more and the other three people get 12 more so the totals are 14 + 14 + 14 + 13 + 13 + 13 = 81
Author Commented:
Thanks.. Let's see if I can answer that.

Each person only gets the number of picks next to their name

Mike gets 21 picks so roughly 1 pick every 4
Josh gets 16 picks so roughly 1 pick every 5
Drew 15 picks so roughly 1 pick every 5 (rounding)
Bill gets 10 picks so roughly 1 pick every 8
Matt gets 9 picks so roughly 1 pick every 9
Todd gets 8 picks so roughly 1 pick every 10

Does that make sense?

I'm really looking for a way to allow me to use this formula over and over without much effort. i.e. if next year I decide to change the number if will recalculate based on the new numbers.

Thanks
Older than dirtCommented:
Sorry but I'm still not totally getting it.

What I think I understand is that you have 81 tickets and in the 1st round everybody picks one.  Do you want something more than just to randomly assign 20 of the remaining tickets to Mike and 15 to Josh, etc? Or perhaps you want a list that essentially says

Mike's turn
Drew's turn
Bill's turn
etc in random order

where there would be a total of 20 Mike's,  15 Josh's etc?
Author Commented:
Sorry, It's my fault for not explaining it well. (Hence the horrible title). :-)

I'm looking for a turn list so to speak.

Here is how I envisioned it ( a list 1 - 81)

1. Mike
2. Josh
3. Drew
4. Bill
5. Matt
6. Todd

That's picks 1 -6 because everyone gets one pick right away based on their total numbers.

With me so far?

As for 7 - 81 , I need some kind of algorithm around it.

Here is my initial thoughts but

7. Mike
8. Josh
9. Drew

But that's where I lose the logic.. We have to start the picks off again with Mike because he gets the most picks and then we need to split everyone out so everyone is really only getting a pick based on their percentage of 81. Mike every 4, Josh and Drew every 5ish, Bill every 8, Matt every 9 and Todd every 10.

Honestly, I think I'm confusing myself. In  my mind I know what I'm trying to say but it's not explaining correctly.
Older than dirtCommented:
You say that "We have to start the picks off again with Mike because he gets the most picks". Is it also true that Josh has to be second all the time because he has the 2nd most picks?
Author Commented:
Not necessarily. I think as we start getting lower and lower in the picks the decimals will come into play. 81/21 is not really 1 every 4 picks for Mike, it's really like 3.8 and Josh's 81/16 is really 5.06.
Older than dirtCommented:
Okay then what constitutes a round?
Author Commented:
I guess round is a bad choice of a word on my part. It's really just everyone dwindling down their numbers till they get to 0. Everyone keeps getting picks over and over again until their out based on the spacing we talked about earlier.

Here is an example that I did last year by hand that is probably incorrect but shows the order of the first 30 picks (different people)

1      Mike
2      Drew
3      Matthew
4      Josh
5      Mike
6      MB
7      Matthew
8      Drew
9      Mike
10      Josh
11      Matthew
12      Drew
13      Mike
14      MB
15      Matthew
16      Josh
17      Frank
18      Drew
19      Mike
20      Josh
21      Matthew
22      MB
23      Mike
24      Drew
25      Matthew
26      Josh
27      Mike
28      Drew
29      Matthew
30      MB
Older than dirtCommented:
I've got to go out for a few hours. Someone else may be able to help you based on this info but if not I'll give it a shot when I get back.
Author Commented:
No rush.. Thanks.. There might not be a solution. I figured I'd post it up and see if someone could help.

Thanks for all the help so far
Older than dirtCommented:
This may not be what you want, but check it out. It assumes that the players are in col A starting in row 1, and that the tickets they have are next to them in col B.

Private Sub CommandButton1_Click()

Dim intIndex As Integer
Dim intLastRow As Range
Dim intTickets As Integer
Dim intTics() As Integer
Dim intRow As Integer

' Get the last row with data in it
Set intLastRow = Range("A1").End(xlDown).Offset(0, 0)

' Fill and array with the tickets each person has
ReDim intTics(intLastRow.Row)
For intIndex = 1 To intLastRow.Row
intTickets = intTickets + Range("B" & intIndex).Value
intTics(intIndex - 1) = Range("B" & intIndex).Value
Next

Do Until intTics(0) = 0
For intIndex = 1 To intLastRow.Row
If intTics(intIndex - 1) > 0 Then
intRow = intRow + 1
Range("D" & (intRow)).Value = Range("A" & intIndex).Value
intTics(intIndex - 1) = intTics(intIndex - 1) - 1
End If
Next
Loop
Older than dirtCommented:
Okay I think this is better. After displaying Mike's name the names of the others are displayed in a random fashion. The same assumptions are made as in my previous post.

``````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
``````
Author Commented:
Thanks.. I'll take a look at this in a bit. I appreciate the help
Older than dirtCommented:
When you run the second code you'll find that 'Mike' gets the last 4 or 5 picks. I'm working on another approach that evens it out more.
Older than dirtCommented:
This fixes the problem of Mike having the last several picks but it creates a different small problem and that is that Mike winds up with 2 of the first 6 picks (which I assume is a 'round') and Todd none, and I believe you want everyone to get one pick in the first round. I'll wait until you try this code before I fix that problem. It shouldn't be difficult but I don't want to do it until I hear from you. Here's the code (you'll also need the ShuffleArray code from the last post)

``````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
``````
Author Commented:
Do I just add the ShuffleArray code from the first post to the end of the 2nd post?
Author Commented:
Getting an error at :

intStep = RoundUp(intTickets / intTics(intIndex))

Sub or Function not defined
Older than dirtCommented:

Function RoundUp(ByVal X As Double) As Double
Dim Temp As Double
Temp = Int(X)
RoundUp = Temp + IIf(X = Temp, 0, 1)
End Function
Older than dirtCommented:
I went ahead and modified the code so that everyone gets a pick in round 1.

``````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
``````

If you are interested, my profile contains links to some articles that I've written.
Marty - MVP 2009, 2010, 2011
Author Commented:
Thanks.. Let me rerun it again.. It'll be later tonight though.

The spacing seems a bit off but I can't put my finger on it yet.
Older than dirtCommented:
Well what it's doing is (now after the first round) evenly spacing the names based on how many there are, and there are 1 or 2 left over for each player at the end of that process along with a matching number of blank lines. I then randomly fill the blank lines with the remaining names and that could lead to someone getting two picks in a row.
Author Commented:
This looks great.. Thanks for all the hard work. Question though.

Is there any way to get the spacing more even?

If Matt is supposed to get a pick every 9 picks or so then I would like to not see it waiver by more than 2 either way. i.e. He gets a pick between every 7 to every 11.

Is there any way to put in that kind of logic?

Thanks

Josh
Older than dirtCommented:
After the 1st round 9.125 to be exact, but since it needs to be done in whole number Steps I round that 10 which in Matt's case leaves 2 unassigned and as I said previously I assign those 2 randomly to the remaining blank rows.

I did however find a logic error which I corrected with a couple of small changes.

``````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
``````

If this answer satisfies you please do me a favor and accept my post ID: 37750364.
Author Commented:
Thanks.. This looks good. I'll need to go in and massage it by hand as I can't have someone making two picks in a row or 2 apart but other than that it looks good.

Why post 37750364 ? The one above has better logic?

I would make a new post to access that has everything, including the functions in it.
Older than dirtCommented:
I shouldn't have asked you to pick that post so ignore that please.

I'm going to see if I can fix the two picks in a row problem.
Author Commented:
No worries on the post. Didn't make sense so I figured I would ask.

About the two picks in a row. When it fills in the blanks could it see what their average pick should be and find one that is the closest to that? Doesn't need to be exact but if their average pick is 9 and they get a 1 then it's an issue.
Older than dirtCommented:
I think you'll find that this is an improvement.  Instead of randomly filling the blank lines with the remaining names it first checks to see if there's an empty row where the players name does not appear in either of the two rows above or two rows below. If it can't find that situation it checks for an empty row where the players name does not appear in the row directly above or below. If it can't find that situation it defaults to the first empty row. Note that with the data I've been working with that the default situation is not needed. In other words the code always finds an empty slot by way of one of the first two checks. Here's the complete code (you don't need ShuffleArray any more).

I've enjoyed working on this.

``````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
``````
Author Commented:
Martin, thanks so much for working on this. Even if we can't get it perfect this is great and I truly appreciate the effort you've put into it.

I'll throw out some things here and see if anything can be done, if it can't then this gets me 95% of the way there.

Matt, he has pick 46 and 49. Other than that it's great. His spacing should be 9 but he has 3

Todd, he starts off with picks that are spaced 9,11,12,9 then he drops to 5,6,6,6.. His spacing should be around 8. I bet it evens out overall though.

Drew goes through similar at 33/36 and 54/57
Older than dirtCommented:
I don't get the same results and it's probably because the number of tickets are different. Way back in your original post you said that there were a total of 81 tickets but the example you gave for the details was

Mike        21
Josh        16
Drew  15
Bill         10
Matt         9
Todd         8

and that's what I'm using even though they only add up to 79.

As for the irregular spacing, that's happening because people are competing for the same slots. Given the 79 tickets and the requirement that everyone get a turn in the 1st round the first two columns in this picture show the rows that, ideally, Mike and Josh would get.
The red lines point out the conflicts and in my scheme Mike gets priority since he has the most tickets and Josh's rows get pushed down one for each conflict as indicated by the blue lines. If you count the rows for Mike and Josh you'll find that they are each missing one pick. That's because the spacing obviously has be in whole rows and the rounding causes one pick for each that would have to go in a row higher than 79. Using the filling of the blank rows that I described in my last post, Mike's left over one gets put in row 17 and Josh's gets put in row 21.

Run my code again with the 79 tickets and let's talk about any spots in the list that concern you.
Author Commented:
Martin, it was my mistake on the tickets. I realized it after I posted.

It should be

Mike        21
Josh        16
Drew  15
Bill         10
Todd      10
Matt         9
Older than dirtCommented:
Okay. Here's an improvement and I think it's about the best I can do.

``````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 want to it would be pretty easy to modify FindBest to look for the name 5 rows (or more) above or below the empty row.

When you run the code you'll get a row assignment that when analyzed looks like this picture. The first column in the pair of columns for each player is the row assigned and the 'Diff' column shows the spacing between the occurrences. The number in the parenthesis is the ideal spacing. Note that players with the lowest number of tickets vary the most from the ideal because they compete for the same row with people with more tickets and I give the 'more ticket' people priority. (This was done by hand so there could be errors).

Experts Exchange Solution brought to you by