Solved

Determining the order of a list based on a number

Posted on 2012-03-20
35
183 Views
Last Modified: 2012-03-23
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
0
Comment
Question by:JoshFink
  • 19
  • 16
35 Comments
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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
 

Author Comment

by:JoshFink
Comment Utility
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
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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
 

Author Comment

by:JoshFink
Comment Utility
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
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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?
0
 

Author Comment

by:JoshFink
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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
 

Author Comment

by:JoshFink
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
Okay then what constitutes a round?
0
 

Author Comment

by:JoshFink
Comment Utility
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
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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.
0
 

Author Comment

by:JoshFink
Comment Utility
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
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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

Open in new window

0
 

Author Comment

by:JoshFink
Comment Utility
Thanks.. I'll take a look at this in a bit. I appreciate the help
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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

Open in new window

0
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 

Author Comment

by:JoshFink
Comment Utility
Do I just add the ShuffleArray code from the first post to the end of the 2nd post?
0
 

Author Comment

by:JoshFink
Comment Utility
Getting an error at :

   intStep = RoundUp(intTickets / intTics(intIndex))

Sub or Function not defined
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
Sorry about that.


Function RoundUp(ByVal X As Double) As Double
   Dim Temp As Double
     Temp = Int(X)
     RoundUp = Temp + IIf(X = Temp, 0, 1)
End Function
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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

Open in new window



If you are interested, my profile contains links to some articles that I've written.
Marty - MVP 2009, 2010, 2011
0
 

Author Comment

by:JoshFink
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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
 

Author Comment

by:JoshFink
Comment Utility
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
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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

Open in new window


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

Author Comment

by:JoshFink
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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
 

Author Comment

by:JoshFink
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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

Open in new window

0
 

Author Comment

by:JoshFink
Comment Utility
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
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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.
IdealThe 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
 

Author Comment

by:JoshFink
Comment Utility
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
0
 
LVL 45

Accepted Solution

by:
Martin Liss earned 500 total points
Comment Utility
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

Open in new window


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

Analysis
0
 

Author Comment

by:JoshFink
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
You should accept the one you're going to use.

I'm glad I was able to help.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

What is a Form List Box? (skip if you know this) The forms List Box is the alternative to the ActiveX list box. If you are using excel 2007, you first make sure you have a developer tab (click the Orb)->"Excel Options"->Popular->"Show Developer tab…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now