PDA

View Full Version : Sleeper: Matching Algorithm - Gale Shapley, Almost complete - Excel Matching



Lee_of_Exce1
04-10-2019, 10:34 PM
Matching Algorithm - Gale Shapley, Almost complete - Excel Matching

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
04-10-2019, 11:45 PM
Cross-posted at: https://www.mrexcel.com/forum/excel-questions/1094072-matching-algorithm-gale-shapley-almost-complete-excel-matching.html
Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#faq_new_faq_item3

Lee_of_Exce1
04-14-2019, 09:32 PM
I have also posted this post to the following other forums, but I have currently not received a reply on any.

https://www.mrexcel.com/forum/excel-questions/1094072-matching-algorithm-gale-shapley-almost-complete-excel-matching.html#post5258993
https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1217301-matching-algorithm-gale-shapley-almost-complete-excel-matching