Gale Shapley matching (Stable Marriage problem)

Fascinating little problem! Thanks for posting it, I've enjoyed spending the last couple of hours working through this logic!

See attachment for a worked example. I used the example dataset from Rosetta Code, stored in a couple of listobject tables.

The code reads in the arrays of Men and Women with their preferences, then loops through, according to the algorithm:

Originally Posted by Wikipedia

function stableMatching {
    Initialize all m ∈ M and w ∈ W to free
    while ∃ free man m who still has a woman w to propose to {
       w = first woman on m’s list to whom m has not yet proposed
       if w is free
         (m, w) become engaged
       else some pair (m', w) already exists
         if w prefers m to m'
            m' becomes free
           (m, w) become engaged 
         else
           (m', w) remain engaged
    }
}

You could easily tweak the input source(s). The output is stored in the respective arrays, with a text log written to the log sheet. You could do whatever you like with the output.

Here's my code:

Sub GaleShapelyArray()
    Dim arrMen() As Variant
    Dim vMan As Variant
    Dim lMan As Long
    Dim lManPref As Long
    Dim lManDown As Long
    
    Dim arrWomen() As Variant
    Dim vWoman As Variant
    Dim lWoman As Long
    
    Dim i As Integer
    Dim lPeople As Long
    Dim lPartner As Long
    
    On Error GoTo Terminate
    Application.ScreenUpdating = False
    
    shLog.UsedRange.Offset(1, 0).Clear
    WriteLog "Procedure GaleShapelyArray started"
    
    arrMen = shArray.ListObjects("tbManArray").DataBodyRange
    arrWomen = shArray.ListObjects("tbWomanArray").DataBodyRange
    
    For i = 1 To 2
        If Not UBound(arrMen, i) = UBound(arrWomen, i) Then
            Err.Raise -1001, , "Array dimensions do not match"
        End If
    Next i
    
    lPeople = UBound(arrMen, 1)
    lPartner = UBound(arrMen, 2) + 1
    
    ReDim Preserve arrMen(1 To lPeople, 1 To lPartner)
    ReDim Preserve arrWomen(1 To lPeople, 1 To lPartner)
    
    Do Until UnmatchedMen(arrMen, lPartner) = 0
        WriteLog "Unmatched Men: " & UnmatchedMen(arrMen, lPartner)
        For lMan = LBound(arrMen, 1) To UBound(arrMen, 1)
            vMan = arrMen(lMan, 1)
            If arrMen(lMan, lPartner) = 0 Then
                'Man has no partner
                For lManPref = 2 To lPartner - 1
                    vWoman = arrMen(lMan, lManPref)
                    lWoman = FindPerson(arrWomen, vWoman)
                    'Woman has no partner
                    If arrWomen(lWoman, lPartner) = 0 Then
                        arrWomen(lWoman, lPartner) = vMan
                        arrMen(lMan, lPartner) = vWoman
                        WriteLog vWoman & " ACCEPTED " & vMan
                        GoTo NextMan
                    End If
                    'Woman has partner
                    lManDown = FindPerson(arrMen, arrWomen(lWoman, lPartner))
                    If FindPersonPref(arrWomen, lWoman, vMan) < FindPersonPref(arrWomen, lWoman, arrWomen(lWoman, lPartner)) Then
                        'New man is preferred
                        arrMen(lManDown, lPartner) = 0
                        WriteLog vWoman & " REJECTED " & arrMen(lManDown, 1)
                        arrWomen(lWoman, lPartner) = vMan
                        arrMen(lMan, lPartner) = vWoman
                        WriteLog vWoman & " ACCEPTED " & vMan
                        GoTo NextMan
                    End If
                Next lManPref
            End If
NextMan:
        Next lMan
    Loop
    WriteLog "OUTPUT:"
    For i = 1 To lPeople
        WriteLog arrWomen(i, 1) & " is engaged to " & arrWomen(i, lPartner)
    Next i
    WriteLog "Procedure GaleShapelyArray complete"
Terminate:
    If Err Then
        Debug.Print "ERROR", Err.Number, Err.Description
        Err.Clear
    End If
    Application.ScreenUpdating = True
End Sub


Function UnmatchedMen(ByRef arrMen() As Variant, ByVal lColPartner As Variant)
    Dim i As Integer
    UnmatchedMen = 0
    For i = LBound(arrMen, 1) To UBound(arrMen, 1)
        If arrMen(i, lColPartner) = 0 Then UnmatchedMen = UnmatchedMen + 1
    Next i
End Function


Function FindPerson(ByRef arrPeople() As Variant, ByVal vPerson As Variant) As Long
    Dim lPerson As Long
    For lPerson = LBound(arrPeople, 1) To UBound(arrPeople, 1)
        If arrPeople(lPerson, 1) = vPerson Then
            FindPerson = lPerson
            Exit Function
        End If
    Next lPerson
End Function

Function FindPersonPref(ByRef arrPeople() As Variant, ByVal lPerson As Long, ByVal vPerson As Variant) As Long
    Dim lPersonPref As Long
    For lPersonPref = LBound(arrPeople, 2) To UBound(arrPeople, 2)
        If arrPeople(lPerson, lPersonPref) = vPerson Then
            FindPersonPref = lPersonPref
            Exit Function
        End If
    Next lPersonPref
End Function

Function WriteLog(ByVal s As String)
    Debug.Print s
    With shLog.Cells(Rows.Count, 1).End(xlUp)
        .Offset(1, 0).Value = Now
        .Offset(1, 1).Value = s
    End With
End Function

I enjoyed that!