Matching Algorithm - Gale Shapley, Almost complete - Excel Matching

[Lee_of_Excel]

Current Progress: Currently I have a Gale and Shapley Algorithm (in the attached spreadsheet) which matches partners in 2 tables on sheet "Array" (Man & preferences vs Woman & preferences) and then records the results on sheet "Log". It works well.
Goal: I want to change this to 3 Sheets - I want to be able to enter the <UNIQUE_ID_NAME> in Column A on Sheet1 and <UNIQUE_ID_PREFERENCES> in Column B,C,D,E,F, etc (can be different amount of preferences per Unique_ID_Name)
and Match this against the same fields in Sheet 2 <UNIQUE_ID_CODE>, which then produces the results of the match in Sheet 3.
There can be a different number of Unique_ID_Name and Unique_ID_Format in Sheet 1 vs Sheet 2 and a different number of preferences, so some may result in no match.
The matches can't double up and it's fine to have a no match scenario.
I have included my spreadsheet with the current match and a spreadsheet of what I would like my goal to look like.
I will be using this matching system with around 100 rows each time.
Any help is greatly appreciated

Option Explicit
Sub MatchingArray()
    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 MatchingArray 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 MatchingArray complete - Bazinga!"
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

Cheers
Lee

 

[Macropod]

Cross-posted at: www.vbaexpress.com/forum/showthread...m-Gale-Shapley-Almost-complete-Excel-Matching
Please read Mr Excel's policy on Cross-Posting in rule 13: http://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html

 

[Lee_of_Excel]

I have also posted this post to the following other forums, but I have currently not received a reply on any.

http://www.vbaexpress.com/forum/sho...t-complete-Excel-Matching&p=389819#post389819
https://www.ozgrid.com/forum/forum/...m-gale-shapley-almost-complete-excel-matching