• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Match Mentors to Mentees (With large test data)

According to tests on Mac six years ago MDictionary could be slower than under Windows but faster than Excel basics like Demo1r uses …​
​
 
The 'Instant' way - different result according to the first match - with the linear classic VBA 'full array loop'​
to paste only to the result worksheet module :​
Code: 
Sub Demo3()
  Const D = "¤"
    Dim V, K$(), W, L&, R&, S$
        UsedRange.Clear
    With Sheet1
        If .[IF(ISNUMBER(G3),G3,0)] < 1 Then Beep: Exit Sub
        V = .Range("A3:G" & .[A1].CurrentRegion.Rows.Count)
    End With
    With Sheet2.[A1].CurrentRegion.Rows
        If .Count < 3 Then Beep: Exit Sub
        Application.ScreenUpdating = False
       .Range("A3:B" & .Count).Copy [A2]
       .Range("D3:F" & .Count).Copy [E2]
    End With
        ReDim K(1 To UBound(V))
    With UsedRange.Columns
       .Item("E:G").Font.ColorIndex = 16
        W = .Item("C:G")
' Gender & Programme & Code
    For L = 1 To UBound(V)
        If Not Application.IsNumber(V(L, 7)) Then V(L, 7) = V(1, 7)
        If V(L, 7) > 0 Then K(L) = V(L, 4) & D & V(L, 5) & D & V(L, 6)
    Next
    For R = 1 To .Rows.Count
        If IsEmpty(W(R, 1)) Then
                S = W(R, 3) & D & W(R, 4) & D & W(R, 5)
            For L = 1 To UBound(V)
                If K(L) = S Then
                    W(R, 1) = V(L, 1)
                    W(R, 2) = V(L, 2)
                   .Item("E:G").Rows(R).Font.ColorIndex = xlAutomatic
                    V(L, 7) = V(L, 7) - 1:  If V(L, 7) = 0 Then K(L) = ""
                    Exit For
                End If
            Next
        End If
    Next
' Programme & Code
    For L = 1 To UBound(V)
        If V(L, 7) > 0 Then K(L) = V(L, 5) & D & V(L, 6)
    Next
    For R = 1 To .Rows.Count
        If IsEmpty(W(R, 1)) Then
                S = W(R, 4) & D & W(R, 5)
            For L = 1 To UBound(V)
                If K(L) = S Then
                    W(R, 1) = V(L, 1)
                    W(R, 2) = V(L, 2)
                   .Item("F:G").Rows(R).Font.ColorIndex = xlAutomatic
                    V(L, 7) = V(L, 7) - 1:  If V(L, 7) = 0 Then K(L) = ""
                    Exit For
                End If
            Next
        End If
    Next
' Gender & Programme
    For L = 1 To UBound(V)
        If V(L, 7) > 0 Then K(L) = V(L, 4) & D & V(L, 5)
    Next
    For R = 1 To .Rows.Count
        If IsEmpty(W(R, 1)) Then
                S = W(R, 3) & D & W(R, 4)
            For L = 1 To UBound(V)
                If K(L) = S Then
                    W(R, 1) = V(L, 1)
                    W(R, 2) = V(L, 2)
                   .Item("E:F").Rows(R).Font.ColorIndex = xlAutomatic
                    V(L, 7) = V(L, 7) - 1:  If V(L, 7) = 0 Then K(L) = ""
                    Exit For
                End If
            Next
        End If
    Next
' Programme
    For L = 1 To UBound(V)
        If V(L, 7) > 0 Then K(L) = V(L, 5)
    Next
    For R = 1 To .Rows.Count
        If IsEmpty(W(R, 1)) Then
                S = W(R, 4)
            For L = 1 To UBound(V)
                If K(L) = S Then
                    W(R, 1) = V(L, 1)
                    W(R, 2) = V(L, 2)
                   .Cells(R, 6).Font.ColorIndex = xlAutomatic
                    V(L, 7) = V(L, 7) - 1:  If V(L, 7) = 0 Then K(L) = ""
                    Exit For
                End If
            Next
        End If
    Next
' Gender & Code
    For L = 1 To UBound(V)
        If V(L, 7) > 0 Then K(L) = V(L, 4) & D & V(L, 6)
    Next
    For R = 1 To .Rows.Count
        If IsEmpty(W(R, 1)) Then
                S = W(R, 3) & D & W(R, 5)
            For L = 1 To UBound(V)
                If K(L) = S Then
                    W(R, 1) = V(L, 1)
                    W(R, 2) = V(L, 2)
                   .Rows(R).Range("E1,G1").Font.ColorIndex = xlAutomatic
                    V(L, 7) = V(L, 7) - 1:  If V(L, 7) = 0 Then K(L) = ""
                    Exit For
                End If
            Next
        End If
    Next
' Code
    For L = 1 To UBound(V)
        If V(L, 7) > 0 Then K(L) = V(L, 6)
    Next
    For R = 1 To .Rows.Count
        If IsEmpty(W(R, 1)) Then
                S = W(R, 5)
            For L = 1 To UBound(V)
                If K(L) = S Then
                    W(R, 1) = V(L, 1)
                    W(R, 2) = V(L, 2)
                   .Cells(R, 7).Font.ColorIndex = xlAutomatic
                    V(L, 7) = V(L, 7) - 1:  If V(L, 7) = 0 Then K(L) = ""
                    Exit For
                End If
            Next
        End If
    Next
' Gender
    For L = 1 To UBound(V)
        If V(L, 7) > 0 Then K(L) = V(L, 4)
    Next
    For R = 1 To .Rows.Count
        If IsEmpty(W(R, 1)) Then
                S = W(R, 3)
            For L = 1 To UBound(V)
                If K(L) = S Then
                    W(R, 1) = V(L, 1)
                    W(R, 2) = V(L, 2)
                   .Cells(R, 5).Font.ColorIndex = xlAutomatic
                    V(L, 7) = V(L, 7) - 1:  If V(L, 7) = 0 Then K(L) = ""
                    Exit For
                End If
            Next
        End If
    Next
' last mentors to last mentees
        L = 1
    For R = 1 To .Rows.Count
        If IsEmpty(W(R, 1)) Then
            Do
                If V(L, 7) Or L = UBound(V) Then Exit Do Else L = L + 1
            Loop
                If V(L, 7) Then V(L, 7) = V(L, 7) - 1 Else Exit For
                W(R, 1) = V(L, 1)
                W(R, 2) = V(L, 2)
        End If
    Next
       .Item("C:D") = W
    End With
        [A1:G1] = [{"Mentee ID","Mentee Name","Mentor ID","Mentor Name","Gender","Programme","Code"}]
        Application.ScreenUpdating = True
End Sub
You may Like it !​
​
 
Marc L said:
The same on my side under Windows, as I wrote in post #88 it could be four times faster …​
Did you test on Mac ?​
​
Click to expand...

In Macbook Air m1 chipset, the result also appeared instantly after clicking the "Run" in Marcos.

Same sample file with #99 Post, which is a data set (1:10 ratio): 98 mentors to 973 mentees
 
You must log in or register to reply here.
Back
Top