MATCHING COLLECTION DATA WITH ORIGINAL TABLE IT CAME FROM (CAJUN, AHEM

[docmeizie]

This question is more directed to CajunCenturion since he helped me with the original code; but any input, idea, advice from others is more than welcome.

Well Mr. Cajun if you remember you gave me some very helpful code to create a Round Robin Scheduler for this Softball league I am making a program for. You also checked my code for the randomization of the teams so they could be put in a random order. Well at any rate the randomizer works good and the scheduler works good and together they work great. One thing that I want to do is be able to match the numbers that I get from the Scheduler back with the numbers I get from the Randomizer and put them in a table together. Can you point me in the right direction????

Public Function RoundRobin(NumTeam As Integer, Rotations As Integer) As Collection

Dim Schedule As New Collection
Dim IsEven As Boolean
Dim LeftTeam() As Integer
Dim RghtTeam() As Integer
Dim HalfTeam As Integer
Dim LastTeam As Integer
Dim TeamNum As Integer
'Dim Rotations As Integer
Dim Idx1 As Integer
Dim Idx2 As Integer
Dim GameID As String
Dim SaveTeam As Integer

IsEven = ((NumTeam / 2) = (NumTeam \ 2))
HalfTeam = IIf((IsEven), Int(NumTeam / 2), (Int(NumTeam / 2) + 1))
LastTeam = HalfTeam - 1
ReDim LeftTeam(LastTeam)
ReDim RghtTeam(LastTeam)

TeamNum = IIf((IsEven), 1, 0)
For Idx1 = 0 To LastTeam
LeftTeam(Idx1) = TeamNum
RghtTeam(Idx1) = TeamNum + HalfTeam
TeamNum = TeamNum + 1
Next Idx1

Set Schedule = New Collection

'Rotations = IIf((IsEven), (NumTeam - 1), (NumTeam))
For Idx1 = 1 To Rotations
'Schedule.Add "ROUND: " & Trim(Idx1)
'Schedule.Add "-------------"
For Idx2 = 0 To LastTeam
If (LeftTeam(Idx2) > 0) Then
GameID = Trim(RghtTeam(Idx2)) & " vs " & Trim(LeftTeam(Idx2))
Else
GameID = Trim(RghtTeam(Idx2)) & " Idle"
End If
Schedule.Add GameID
Next Idx2

SaveTeam = LeftTeam(1)
For Idx2 = 1 To LastTeam - 1
LeftTeam(Idx2) = LeftTeam(Idx2 + 1)
Next Idx2
LeftTeam(LastTeam) = RghtTeam(LastTeam)
For Idx2 = LastTeam To 1 Step -1
RghtTeam(Idx2) = RghtTeam(Idx2 - 1)
Next Idx2
RghtTeam(0) = SaveTeam
Next Idx1

Set RoundRobin = Schedule

'MsgBox Schedule, , "Sample Schedule"


End Function

Public Function RandomizeThenSplit()
Dim Idx As Integer
Dim Idx2 As Integer
Dim TeamCollect1 As New Collection
Dim TeamCollect2 As New Collection
Dim ThisTeam As Class2
Dim NameList As String
Dim NameList2 As String
Dim myclasses1 As New Collection
Dim myclasses2 As New Collection
Dim MyObject As Variant
Dim IsEven As Boolean
Dim HalfTeam As Integer
Dim NumTeam As Integer

For Idx = 0 To lstTeams.ListCount
If (Len(lstTeams.ItemData(Idx) > "")) Then
Set ThisTeam = New Class2
ThisTeam.InstanceName = lstTeams.ItemData(Idx)
TeamCollect1.Add Item:=ThisTeam
Set ThisTeam = Nothing
End If
Next Idx

NumTeam = lstTeams.ListCount
IsEven = ((NumTeam / 2) = (NumTeam \ 2))
HalfTeam = IIf((IsEven), Int(NumTeam / 2), (Int(NumTeam / 2) + 1))

Randomize
Do While TeamCollect1.Count > 0
For Idx2 = 1 To HalfTeam
Idx = Int((Rnd * TeamCollect1.Count) + 1)
myclasses1.Add TeamCollect1.Item(Idx)
TeamCollect1.Remove (Idx)
Next Idx2
For Idx2 = 1 To (NumTeam - HalfTeam)
Idx = Int((Rnd * TeamCollect1.Count) + 1)
myclasses2.Add TeamCollect1.Item(Idx)
TeamCollect1.Remove (Idx)
Next Idx2
Loop

Idx = 0
For Each MyObject In myclasses1 ' Create list of names.
Idx = Idx + 1
NameList = NameList & Idx & ")  " & MyObject.InstanceName & Chr(13)
Next MyObject

Idx = 0
For Each MyObject In myclasses2 ' Create list of names.
Idx = Idx + 1
NameList2 = NameList2 & Idx & ")  " & MyObject.InstanceName & Chr(13)
Next MyObject

MsgBox NameList, , "Team Names In League A Collection"
MsgBox NameList2, , "Team Names In League B Collection"
LeagueA = myclasses1.Count
LeagueB = myclasses2.Count
Set myclasses1 = Nothing
Set myclasses2 = Nothing
End Function

thank for any help in advanced.

If I take a peek in your Windows, to fix a problem, does that make me a "Peeping Tom"? Hmmmmmmmmmmv

 

[CajunCenturion]

Yes, I remember, vaguely. I'll need to find some time to get back into it, so please be patient. Things are quite busy right now.

Good Luck
--------------
To get the most from your Tek-Tips experience, please read FAQ181-2886
As a circle of light increases so does the circumference of darkness around it. - Albert Einstein

 

[docmeizie]

That's no problem, take your time.

If I take a peek in your Windows, to fix a problem, does that make me a "Peeping Tom"? Hmmmmmmmmmmv

 

[CajunCenturion]

Sorry it took so long. I'm not sure how much help this may be, because I cannot see what is going on inside RandomizeThenSplit routine because I don't have the definition of your class "Class2"

One thing that you might want to try is simply to build an array (1-based) that associates a team with a given number. Then after computing the schedule, use the team numbers as references into the TeamName array to complete the task. Using just the RoundRobin portion, here is an example that builds an array of collections, one per round, which each collection showing who plays whom.

Dim TeamNames(1 To 10)  As String
Dim TheSchedule         As Collection
Dim TheRounds(9)        As Collection
Dim Idx                 As Integer
Dim NumTeams            As Integer
Dim NumGames            As Integer
Dim NumRotates          As Integer
Dim ThisGame()          As String
Dim GameDesc            As String
Dim RoundNumber         As Integer
Dim RoundCounter        As Integer
   
TeamNames(1) = "Philadelphia Eagles"
TeamNames(2) = "Arizona Cardinals"
TeamNames(3) = "New Orleans Saints"
TeamNames(4) = "Atlanta Falcons"
TeamNames(5) = "Green Bay Packers"
TeamNames(6) = "New York Giants"
TeamNames(7) = "Buffalo Bills"
TeamNames(8) = "Miami Dolphins"
TeamNames(9) = "St. Louis Rams"
TeamNames(10) = "Idle"
   
NumTeams = 10
NumRotates = NumTeams - 1

Set TheSchedule = RoundRobin(NumTeams, NumRotates)
   
For Idx = 1 To NumRotates
   Set TheRounds(Idx) = New Collection
Next Idx
   
RoundNumber = 1
RoundCounter = 0
NumGames = NumTeams / 2
TheRounds(RoundNumber).Add "Round Number:  " & Trim(RoundNumber)
For Idx = 1 To TheSchedule.Count
   RoundCounter = RoundCounter + 1
   ThisGame = Split(TheSchedule.Item(Idx))
   GameDesc = TeamNames(Val(ThisGame(0))) & " vs " & TeamNames(Val(ThisGame(2)))
   TheRounds(RoundNumber).Add GameDesc
   If (RoundCounter = NumGames) Then
      RoundCounter = 0
      RoundNumber = RoundNumber + 1
      If (RoundNumber <= NumRotates) Then
         TheRounds(RoundNumber).Add "Round Number:  " & Trim(RoundNumber)
      End If
   End If
Next Idx
            
For Idx = 1 To NumRotates
   GameDesc = ""
   For NumGames = 1 To TheRounds(Idx).Count
      GameDesc = GameDesc & TheRounds(Idx).Item(NumGames) & vbCrLf
   Next NumGames
   MsgBox GameDesc
Next Idx

Good Luck
--------------
To get the most from your Tek-Tips experience, please read FAQ181-2886
As a circle of light increases so does the circumference of darkness around it. - Albert Einstein

 

[docmeizie]

Okay this looks like it just may do the trick. There are three ways the teams could be split up by talking to the person I am doing this for. One way was to just split the teams into two smaller divisions if over eigth teams registered (now its down to six teams). Method two was to randomize the teams then split them up into two smaller divisions. That was to prevent people from complaining about the what division of the league they were in. Method three was to split the teams into two smaller divisions and then randomize the samller divisions. So the functions were called Split, RandomizeThenSplit, and SplitThenRandomize. But the way I have it in that code above it splits then randomizes each group of teams. That's only cause I was using a template from other code and had not change the new code to a function by itself.

If I take a peek in your Windows, to fix a problem, does that make me a "Peeping Tom"? Hmmmmmmmmmmv