We’ve posted a new Expert Spotlight! Joe Anderson (DatabaseMX) has been on Experts Exchange since 2006. Learn more about this database architect, guitar aficionado, and Microsoft MVP.

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

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

Experts Exchange Solution brought to you by

Enjoy your complimentary solution view.

Get this solution by purchasing an Individual license!
Start your 7-day free trial.

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.

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

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

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?

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.

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

Thanks for all the help so far

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).Of

' 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

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

Function RoundUp(ByVal X As Double) As Double

Dim Temp As Double

Temp = Int(X)

RoundUp = Temp + IIf(X = Temp, 0, 1)

End Function

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

The spacing seems a bit off but I can't put my finger on it yet.

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

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.

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.

I'm going to see if I can fix the two picks in a row problem.

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.

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

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

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.

It should be

Mike 21

Josh 16

Drew 15

Bill 10

Todd 10

Matt 9

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

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Microsoft Excel

From novice to tech pro — start learning today.

Experts Exchange Solution brought to you by

Enjoy your complimentary solution view.

Get this solution by purchasing an Individual license!
Start your 7-day free trial.

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"?