I have a list of 32 people, 29 of whom are “Active”. Every quarter, I need to generate a lunch schedule with certain conditions. A partial list of people looks like this:
The conditions are:
- Three people to a lunch
- The facilitator is chosen at random
- Each person has one lunch per month at most
- Two person combinations (different third person) can repeat after two months
- Three person combinations can repeat after 10 months
It’s to the benefit of the attendees to not have lunch with the same person too often, so the conditions are set to minimize repeated pairings in certain time frames. If I have lunch with Joe this month, there’s no value in having lunch with him next month, even with a different third person, because not enough will have changed with regard to our lunch topic.
My first step is to identify the nouns in my scenario. The nouns are Contact and Lunch so I create a CContact class and a CLunch class and their respective collection classes CContacts and CLunches.
My main procedure is called LunchTrios and looks like this
Public Sub LunchTrios()
Dim lMonth As Long
Dim vaWrite As Variant
Const lFIRST As Long = 7
Const lLAST As Long = 9
FillClasses
Set gclsLunches = New CLunches
If Not IsEmpty(wshLunch.Range("A4").Value) Then
gclsLunches.FillFromRange wshLunch.Range("A4", wshLunch.Cells(wshLunch.Rows.Count, 1).End(xlUp)).Cells
End If
For lMonth = lFIRST To lLAST
gclsLunches.FillMonth lMonth
Next lMonth
For lMonth = lFIRST To lLAST
vaWrite = gclsLunches.LunchesByMonth(lMonth).RangeOutput
wshLunch.Cells(wshLunch.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
Next lMonth
End Sub
The FillClasses procedure reads the contact information from a range and creates a bunch of CContact objects. If wshLunch.Range(“A4”) isn’t empty, that means there are existing lunches and I need to read those in. Existing lunches look like this:
The code to populate existing lunches lives in the CLunches collection class.
Public Sub FillFromRange(rRng As Range)
Dim rCell As Range
Dim clsLunch As CLunch
Dim clsContact As CContact
For Each rCell In rRng.Columns(1).Cells
Set clsLunch = New CLunch
With clsLunch
.LunchDate = rCell.Offset(0, 0).Value
Set clsContact = gclsContacts.ContactByFullName(rCell.Offset(0, 1).Value)
If Not clsContact Is Nothing Then
.Attendees.Add clsContact
.Facilitator = 1
Set clsContact = Nothing
End If
Set clsContact = gclsContacts.ContactByFullName(rCell.Offset(0, 2).Value)
If Not clsContact Is Nothing Then
.Attendees.Add clsContact
Set clsContact = Nothing
End If
Set clsContact = gclsContacts.ContactByFullName(rCell.Offset(0, 3).Value)
If Not clsContact Is Nothing Then
.Attendees.Add clsContact
Set clsContact = Nothing
End If
End With
Me.Add clsLunch
Next rCell
End Sub
As people come and go from the group, sometimes an attendee from a past lunch won’t exist in the contact list anymore. I check to make sure that they exist before I add them to the Attendees property. I also set the Facilitator property to 1 as the facilitator is the first attendee listed. For this code to work, I’m going to need an Attendee property and a Facilitator property in my CLunch class.
'The class level variables
Private mlLunchID As Long
Private mdtLunchDate As Date
Private mclsAttendees As CContacts
Private mlFacilitator As Long
'the getters and setters
Public Property Let Facilitator(ByVal lFacilitator As Long): mlFacilitator = lFacilitator: End Property
Public Property Get Facilitator() As Long: Facilitator = mlFacilitator: End Property
Public Property Let LunchID(ByVal lLunchID As Long): mlLunchID = lLunchID: End Property
Public Property Get LunchID() As Long: LunchID = mlLunchID: End Property
Public Property Let LunchDate(ByVal dtLunchDate As Date): mdtLunchDate = dtLunchDate: End Property
Public Property Get LunchDate() As Date: LunchDate = mdtLunchDate: End Property
'set up and tear down of the Attendees property
Private Sub Class_Initialize()
Set mclsAttendees = New CContacts
End Sub
Private Sub Class_Terminate()
Set mclsAttendees = Nothing
End Sub
Public Property Get Attendees() As CContacts
Set Attendees = mclsAttendees
End Property
I have a CContacts class that holds a bunch of CContact instances. One instance of CContacts is held in a global variable called gclsContacts and that one holds all of the contacts on the wshContacts sheet. Each of my CLunch instances also has a CContacts instance to hold the three attendees. I don’t need a separate Attendees class because it would look just like CContacts. The CContacts class module is a template that defines the characteristics of a Contacts object. The instances that are created from that template are separate animals. They are defined by the same properties, but the values of those properties are different for each instance. For example, every cow has a height and a gender, but not every cow has the same height and gender. Height and gender define a cow (a little simplistically), but each instance of a cow is defined by three things: that it was created from a cow template, its specific height, and its specific gender.
The instance of CContacts that I store in gclsContacts has a Count property just like the instance of CContacts that I store in gclsLunches.Lunch(1).Attendees. But the first instance has a Count value of 32 and the second instance has a Count value of 3.
So far I have gclsContacts that’s holding all my Contact objects and gclsLunches that’s holding all my existing Lunch objects. Each Lunch instance also has up to three Contact objects related to it via its Attendees property. Tomorrow, I’ll loop through the months I want to populate new Lunch objects that meet my conditions. No more farm animal analogies, I promise.
3 thoughts on “Lunch Pairings”
Posting code? Use <pre> tags for VBA and <code> tags for inline.