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.

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

0

JoshFinkAuthor 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.

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

0

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

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.

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?

0

JoshFinkAuthor 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.

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?

0

JoshFinkAuthor 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.

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

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

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 IntegerDim intIndex2 As IntegerDim intLastRow As RangeDim intTics() As IntegerDim intRow As Integer 'The row number in which to display the player's name whose turn it isDim intRnd() As IntegerRandomize' Get the number of the last row with data in itSet intLastRow = Range("A1").End(xlDown).Offset(0, 0)' Fill an array with the tickets each person hasReDim intTics(1 To intLastRow.Row)For intIndex = 1 To intLastRow.Row intTics(intIndex) = Range("B" & intIndex).ValueNext' 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 fashionReDim intRnd(intLastRow.Row - 2)For intIndex = 0 To intLastRow.Row - 2 intRnd(intIndex) = intIndex + 2NextDo 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 NextLoopEnd SubPrivate 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 NextEnd Sub

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 IntegerDim intIndex2 As IntegerDim intLastRow As RangeDim intTics() As IntegerDim intRow As Integer 'The row number in which to display the player's name whose turn it isDim strLeftOver() As StringDim intTickets As IntegerDim intStep As IntegerDim intTicsLeft As IntegerDim intNext As IntegerRandomize' Get the number of the last row with data in itSet intLastRow = Range("A1").End(xlDown).Offset(0, 0)' Fill an array with the tickets each person hasReDim intTics(1 To intLastRow.Row)For intIndex = 1 To intLastRow.Row intTics(intIndex) = Range("B" & intIndex).Value intTickets = intTickets + Range("B" & intIndex).ValueNextintTicsLeft = intTicketsFor 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 NextNext' 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 = 1For intIndex = 1 To intLastRow.Row For intIndex2 = 1 To intTics(intIndex) strLeftOver(intNext) = Range("A" & intIndex).Value intNext = intNext + 1 NextNext' Shuffle the remaining namesShuffleArray strLeftOver' Finally fill in the blank rows using the shuffled valuesintNext = 1For intRow = 1 To intTickets If Range("D" & intRow).Value = "" Then Range("D" & intRow).Value = strLeftOver(intNext) intNext = intNext + 1 End IfNext

I went ahead and modified the code so that everyone gets a pick in round 1.

Dim intIndex As IntegerDim intIndex2 As IntegerDim intLastRow As RangeDim intTics() As IntegerDim intRow As Integer 'The row number in which to display the player's name whose turn it isDim strLeftOver() As StringDim intTickets As IntegerDim intStep As IntegerDim intTicsLeft As IntegerDim intNext As IntegerRandomize' Get the number of the last row with data in itSet intLastRow = Range("A1").End(xlDown).Offset(0, 0)' Fill an array with the tickets each person hasReDim intTics(1 To intLastRow.Row)For intIndex = 1 To intLastRow.Row intTics(intIndex) = Range("B" & intIndex).Value intTickets = intTickets + Range("B" & intIndex).ValueNextintTicsLeft = intTickets' In the first round, each person gets a pickFor intIndex = 1 To intLastRow.Row Range("D" & intIndex).Value = Range("A" & intIndex).Value intTics(intIndex) = intTics(intIndex) - 1 intTicsLeft = intTicsLeft - 1NextFor 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 NextNext' 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 = 1For intIndex = 1 To intLastRow.Row For intIndex2 = 1 To intTics(intIndex) strLeftOver(intNext) = Range("A" & intIndex).Value intNext = intNext + 1 NextNext' Shuffle the remaining namesShuffleArray strLeftOver' Finally fill in the blank rows using the shuffled valuesintNext = 1For intRow = 1 To intTickets If Range("D" & intRow).Value = "" Then Range("D" & intRow).Value = strLeftOver(intNext) intNext = intNext + 1 End IfNext

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.

0

JoshFinkAuthor 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.

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 IntegerDim intIndex2 As IntegerDim intLastRow As RangeDim intTics() As IntegerDim intRow As Integer 'The row number in which to display the player's name whose turn it isDim strLeftOver() As StringDim intTickets As IntegerDim intStep As IntegerDim intTicsLeft As IntegerDim intNext As IntegerRandomize' Get the number of the last row with data in itSet intLastRow = Range("A1").End(xlDown).Offset(0, 0)' Fill an array with the tickets each person hasReDim intTics(1 To intLastRow.Row)For intIndex = 1 To intLastRow.Row intTics(intIndex) = Range("B" & intIndex).Value intTickets = intTickets + Range("B" & intIndex).ValueNextintTicsLeft = intTickets' In the first round, each person gets a pickFor intIndex = 1 To intLastRow.Row Range("D" & intIndex).Value = Range("A" & intIndex).Value intTics(intIndex) = intTics(intIndex) - 1 intTicsLeft = intTicsLeft - 1NextFor 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 IfNext' 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 picsintTicsLeft = 0For intIndex = 1 To intLastRow.Row intTicsLeft = intTicsLeft + intTics(intIndex)NextReDim strLeftOver(1 To intTicsLeft)' Create the arrayintNext = 1For intIndex = 1 To intLastRow.Row For intIndex2 = 1 To intTics(intIndex) strLeftOver(intNext) = Range("A" & intIndex).Value intNext = intNext + 1 NextNext' Shuffle the remaining namesShuffleArray strLeftOver' Finally fill in the blank rows using the shuffled valuesintNext = 1For intRow = 1 To intTickets If Range("D" & intRow).Value = "" Then Range("D" & intRow).Value = strLeftOver(intNext) intNext = intNext + 1 End IfNext

If this answer satisfies you please do me a favor and accept my post ID: 37750364.

0

JoshFinkAuthor 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.

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.

0

JoshFinkAuthor 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.

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 IntegerDim intIndex2 As IntegerDim intLastRow As RangeDim intTics() As IntegerDim intRow As Integer 'The row number in which to display the player's name whose turn it isDim strLeftOver() As StringDim intTickets As IntegerDim intStep As IntegerDim intTicsLeft As IntegerDim intNext As IntegerDim bFound As Boolean' Get the number of the last row with data in itSet intLastRow = Range("A1").End(xlDown).Offset(0, 0)' Fill an array with the tickets each person hasReDim intTics(1 To intLastRow.Row)For intIndex = 1 To intLastRow.Row intTics(intIndex) = Range("B" & intIndex).Value intTickets = intTickets + Range("B" & intIndex).ValueNextintTicsLeft = intTickets' In the first round, each person gets a pickFor intIndex = 1 To intLastRow.Row Range("D" & intIndex).Value = Range("A" & intIndex).Value intTics(intIndex) = intTics(intIndex) - 1 intTicsLeft = intTicsLeft - 1NextFor 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 IfNext' 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 picsintTicsLeft = 0For intIndex = 1 To intLastRow.Row intTicsLeft = intTicsLeft + intTics(intIndex)NextReDim strLeftOver(1 To intTicsLeft)' Create the arrayintNext = 1For intIndex = 1 To intLastRow.Row For intIndex2 = 1 To intTics(intIndex) strLeftOver(intNext) = Range("A" & intIndex).Value intNext = intNext + 1 NextNext' Now find the best row for the remaining namesFor 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 IfNextEnd SubPrivate Function FindBest(strName As String, intTickets As Integer) As BooleanDim intRow As IntegerFor 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 IfNextEnd FunctionPrivate Function FindNextBest(strName As String, intTickets As Integer) As BooleanDim intRow As IntegerFor 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 IfNextEnd FunctionPrivate Sub FindFirstEmpty(strName As String, intTickets As Integer)Dim intRow As IntegerFor intRow = 1 To intTickets If Range("D" & intRow).Value = "" Then Range("D" & intRow).Value = strName Exit For End IfNextEnd SubFunction RoundUp(ByVal X As Double) As Double Dim Temp As Double Temp = Int(X) RoundUp = Temp + IIf(X = Temp, 0, 1)End Function

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.

0

JoshFinkAuthor Commented:

Martin, it was my mistake on the tickets. I realized it after I posted.

Okay. Here's an improvement and I think it's about the best I can do.

Private Sub CommandButton1_Click()Dim intIndex As IntegerDim intIndex2 As IntegerDim intLastRow As RangeDim intTics() As IntegerDim intRow As Integer 'The row number in which to display the player's name whose turn it isDim strLeftOver() As StringDim intTickets As IntegerDim intStep As IntegerDim intTicsLeft As IntegerDim intNext As IntegerDim bFound As Boolean' Get the number of the last row with data in itSet intLastRow = Range("A1").End(xlDown).Offset(0, 0)' Fill an array with the tickets each person hasReDim intTics(1 To intLastRow.Row)For intIndex = 1 To intLastRow.Row intTics(intIndex) = Range("B" & intIndex).Value intTickets = intTickets + Range("B" & intIndex).ValueNextintTicsLeft = intTickets' In the first round, each person gets a pickFor intIndex = 1 To intLastRow.Row Range("D" & intIndex).Value = Range("A" & intIndex).Value intTics(intIndex) = intTics(intIndex) - 1 intTicsLeft = intTicsLeft - 1NextFor 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 IfNext' 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 picsintTicsLeft = 0For intIndex = 1 To intLastRow.Row intTicsLeft = intTicsLeft + intTics(intIndex)NextReDim strLeftOver(1 To intTicsLeft)' Create the arrayintNext = 1For intIndex = 1 To intLastRow.Row For intIndex2 = 1 To intTics(intIndex) strLeftOver(intNext) = Range("A" & intIndex).Value intNext = intNext + 1 NextNext' Find the best row for the remaining picksFor intNext = 1 To intTicsLeft FindBest strLeftOver(intNext), intTicketsNextEnd SubPrivate Sub FindBest(strName As String, intTickets As Integer)Dim intRow As IntegerFor 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 IfNextFor 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 IfNextFor 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 IfNextFor 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 IfNextFor intRow = 1 To intTickets If Range("D" & intRow).Value = "" Then Range("D" & intRow).Value = strName Exit Sub End IfNextEnd 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).

0

JoshFinkAuthor Commented:

This is awesome and it works great. Thanks so much for the hard work. Which post is the most complete so that I can accept that one.

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

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