The Person class represents a person and his or her preferences.

The following code performs the assignment. It reads preference information from a text box and builds the Person objects.

Next the code makes initial assignments. For each preference level (in this example, people rank three choices 0, 1, or 2), the code examines the Person objects. If a Person is not yet assigned and that Person's preference for this level has not been assigned, the program makes that assignment.

For example, suppose the program is looking at preference 1 (the second choice). Sally has not been assigned an appointment yet and her choice number 1 is appointment slot 6. If that slot is not already taken by another Person, the program assigns it to Sally.

After it has made these preferential assignments, the program assigns any unassigned Person to any available appointment.

Next the program enters a loop looking for improvements. For each pair of Persons, the program determines whether those persons should trade appointments. For example, suppose Bill was assigned his first choice appointment number 3 and Cindy was assigned appointment number 7, which she did not list as one of her choices. Suppose Bill listed appointment 7 as his third choice and Cindy listed appointment 3 as her second choice. In this case, the program swaps Bill's and Cindy's appointments. It prefers the third/second choices over the first/none choices.

Private Sub cmdGo_Click()
Dim txt As String
Dim num_people As Integer
Dim lines() As String
Dim i As Integer
Dim people() As Person
Dim obj As Variant
Dim per As Person
Dim obj2 As Variant
Dim per2 As Person
Dim assigned_to(0 To NUM_CHOICES - 1) As Person
Dim pref As Integer
Dim desired_choice As Integer
Dim had_improvement As Boolean
Dim per_assignment As Integer
Dim per2_assignment As Integer
Dim old_cost As Integer
Dim new_cost As Integer

    ' Get the Persons' preferences.
    txt = txtPreferences.Text
    Do While Right$(txt, Len(vbCrLf)) = vbCrLf
        txt = Left$(txt, Len(txt) - Len(vbCrLf))
    Loop
    lines = Split(txt, vbCrLf)
    num_people = UBound(lines) - LBound(lines) + 1
    ReDim people(0 To num_people - 1)
    For i = 0 To num_people - 1
        Set people(i) = New Person
        people(i).InitializeValues (lines(i))
    Next i

    ' Clear assignments.
    For i = 0 To NUM_CHOICES - 1
        Set assigned_to(i) = Nothing
    Next i

    ' Make initial choice assignments.
    For pref = 0 To NUM_PREFERENCES - 1
        ' Try to assign this choice for Persons.
        For Each obj In people
            Set per = obj
            ' See if this Person has an assignment yet.
            If per.Assignment < 0 Then
                ' This Person is unassigned.
                ' See if this choice is available.
                desired_choice = per.Preferences(pref + 1)
                If assigned_to(desired_choice) Is Nothing _
                    Then
                    ' Assign this Person.
                    Set assigned_to(desired_choice) = per
                    per.Assignment = desired_choice
                End If
            End If
        Next obj
    Next pref

    ' Assign anyone without an assignment.
    For Each obj In people
        Set per = obj
        ' See if this Person has an assignment yet.
        If per.Assignment < 0 Then
            ' This Person is unassigned.
            ' Find an available choice.
            For i = 0 To NUM_CHOICES - 1
                If assigned_to(i) Is Nothing Then
                    ' Assign this Person.
                    Set assigned_to(i) = per
                    per.Assignment = i
                    Exit For
                End If
            Next i
        End If
    Next obj

    ' Try to improve the assignments.
    Do
        had_improvement = False

        ' Look for profitable swaps.
        For Each obj In people
            Set per = obj

            For Each obj2 In people
                Set per2 = obj2
                per2_assignment = per2.Assignment
                per_assignment = per.Assignment

                ' See if per and per2 should swap.
                old_cost = per.Value + per2.Value
                new_cost = _
                    per.ValueOf(per2_assignment) + _
                    per2.ValueOf(per_assignment)
                If new_cost < old_cost Then
                    ' Make the swap.
                    per.Assignment = per2_assignment
                    per2.Assignment = per_assignment
                    Set assigned_to(per_assignment) = per2
                    Set assigned_to(per2_assignment) = per
                    had_improvement = True
                End If
            Next obj2
        Next obj
    Loop While had_improvement

    ' Display the results.
    txtAssignments.Text = AssignmentSummary(assigned_to, _
        people)
End Sub

Note also that in real life you cannot compare the values of peoples' choices directly. For example, suppose you are available for any of the appointments but I have work during all but one. Then in some sense my first choice is more important than all of your choices. If I don't get my first choice, I need to take extra measures such as getting time off of work.