Populating Lunch Pairings

Yesterday I set up Contact objects and Lunch objects. Now I want to create new Lunch objects that meet the conditions that I defined. From my main LunchTrios procedure:

For lMonth = lFIRST To lLAST
gclsLunches.FillMonth lMonth
Next lMonth

Ah, the brevity that class modules provide is a beautiful thing. I need FillMonth to:

  1. Get a list of active contacts
  2. Create a lunch with three of those contacts
  3. See if that lunch meets my conditions
  4. Keep the lunch if it passes, try another combination if it doesn’t

Public Sub FillMonth(lMonth As Long)

Dim clsLunch As CLunch
Dim dtLunch As Date
Dim i As Long, j As Long, k As Long
Dim bAdded As Boolean
Dim lCnt As Long
Dim clsActive As CContacts

Set clsActive = gclsContacts.Active
dtLunch = DateSerial(Year(Date), lMonth + 1, 0)

For i = 1 To clsActive.Count
bAdded = False
For j = 1 To clsActive.Count
If i <> j Then
For k = 1 To clsActive.Count
If i <> k And j <> k Then
Set clsLunch = New CLunch
clsLunch.LunchDate = dtLunch
clsLunch.Attendees.Add clsActive(i)
clsLunch.Attendees.Add clsActive(j)
clsLunch.Attendees.Add clsActive(k)
clsLunch.Facilitator = CLng((Rnd * (clsLunch.Attendees.Count - 1)) + 1)

If Not clsLunch.IsRepeat Then
Me.Add clsLunch
bAdded = True
lCnt = lCnt + 1
End If
End If
If bAdded Then Exit For
Next k
End If
If bAdded Then Exit For
Next j
If lCnt >= clsActive.Count \ 3 Then Exit For
Next i

End Sub

My first step is to get a list of active participants. I create a new instance of CContacts and store it in the variable called clsActive. Then I create a Property of the CContacts class to return an instance only containing active contacts. My main list of contacts is sorted by first name. I also have 29 active contacts, so two people every month won’t have a lunch. If I keep my contacts sorted, people like Wyatt James are always going to be left out because of his first name. I will have filled up my lunches by the time I get down to him. I need to test lunches in a somewhat random order so that the two people who get left out aren’t the same every month. To do this, I sort clsActive randomly. But I don’t really like sorting right after I populate a class. I have to loop through the contacts to populate the class, then again to sort it. It just seems wasteful. So I do it all in one fell swoop.

Public Property Get Active() As CContacts

Dim clsReturn As CContacts
Dim clsContact As CContact
Dim lRand As Long

Set clsReturn = New CContacts

For Each clsContact In Me
If clsContact.Active Then

lRand = CLng((Rnd * clsReturn.Count) + 1)

If clsReturn.Count = 0 Or lRand > clsReturn.Count Then
clsReturn.Add clsContact
Else
clsReturn.Add clsContact, lRand
End If
End If
Next clsContact

Set Active = clsReturn

End Property

As I added qualified contacts to the collection class, I insert the new contact before a random existing contact. This has the effect of giving me a randomly sorted list of contacts in clsActive.

Now that I have my list of active contacts, I loop through them three times creating a proposed lunch. I check if that lunch meets my conditions with IsRepeat and if so, add it to my Lunches collection class. I have a lot of code in there to skip out of the For loop when it’s found a match because looping takes forever. I also skip out when I have enough lunches for the month.

Next up, I’ll go through the IsRepeat property that checks to see if a lunch meets the conditions.


Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.