Regarding column G, my original ideas are to show the no. of Mentees for specifically for each Mentors. For example, Mentor A and B may have 8 and 5 mentees respectively. For the sample data, it is actually like filling all cells in column G with "10" of the #18 attachment (each mentor will have 10 mentees).
Const D = "¤", K = 16
Dim Rg(1) As Range, V(1)
Sub Check(C%, X)
Dim W, Y, L&, R&, F&, M&, N&
W = [{5,6,7}]
Y = Application.Match(W, X, 0)
For L = 1 To UBound(W): Y(L) = IIf(IsError(Y(L)), Cells(W(L)).Address, D): Next
Y = Join(Filter(Y, D, False), ",")
With UsedRange.Rows
L = .Cells(Rows.Count, 3).End(xlUp)(2).Row: If L > .Count Then Exit Sub
For R = L To .Count
Set Rg(0) = Rg(1)(C).Find(Join(Application.Index(.Item(R), 1, X), D), , xlValues, 1)
If Not Rg(0) Is Nothing Then
F = Rg(0).Row: M = 0
Do
If V(0)(Rg(0).Row, 1) > M Then M = V(0)(Rg(0).Row, 1): N = Rg(0).Row Else If M And V(0)(Rg(0).Row, 1) = M Then Exit Do
Set Rg(0) = Rg(1)(C).FindNext(Rg(0))
Loop Until Rg(0).Row = F
If M Then
.Item(R).Columns("C:D") = Rg(1).Parent.Rows(N).Columns("A:B").Value
If Y > "" Then .Item(R).Range(Y).Font.ColorIndex = K
.Cells(R, .Columns.Count) = 1
V(0)(N, 1) = M - 1
End If
End If
Next
.Item(L & ":" & .Count).Sort .Cells(L, .Columns.Count), 1, Header:=2
End With
End Sub
Sub Demo1r()
Dim R&, X, L&, G%, M&
UsedRange.Clear
With Sheet1
R = .Evaluate("IF(ISNUMBER(G3),G3,0)"): If R < 1 Then Beep: Exit Sub
Set Rg(1) = .UsedRange.Columns
Application.ScreenUpdating = False
Rg(1)("J:M").Formula = Array("=D1&""" & D & """&E1", "=J1&""" & D & """&F1", "=D1&""" & D & """&F1", "=E1&""" & D & """&F1")
V(0) = .Evaluate(Replace("IF(ISNUMBER(#),#,IF(ISNUMBER(" & Rg(1)(1).Address & ")," & R & ",0))", "#", Rg(1)(7).Address))
End With
[A1:H1] = [{"Mentee ID","Mentee Name","Mentor ID","Mentor Name","Gender","Programme","Code"," "}]
With Sheet2.[A1].CurrentRegion.Rows
.Range("A3:B" & .Count).Copy [A2]
.Range("D3:F" & .Count).Copy [E2]
End With
Check 11, [{5,6,7}] ' #1 : Gender & Programme & Code
Check 13, [{6,7}] ' #2 : Programme & Code
Check 10, [{5,6}] ' #3 : Gender & Programme
Check 5, [{6}] ' #4 : Programme
Check 12, [{5,7}] ' #5 : Gender & Code
Rg(1)("J:M").Clear
Check 6, [{7}] ' #6 : Code
V(1) = V(0) ' #7 : Gender
X = Rg(1)(4)
For R = 3 To UBound(X): V(1 + (X(R, 1) = "Male"))(R, 1) = 0: Next
X = Array(1, 1)
With UsedRange.Rows
L = .Cells(Rows.Count, 3).End(xlUp)(2).Row
For R = L To .Count
G = 1 + (.Cells(R, 5) = "Female")
If X(G) Then
M = Application.Match(Application.Max(V(G)), V(G), 0)
If V(G)(M, 1) Then
.Item(R).Columns("C:D") = Rg(1).Parent.Rows(M).Columns("A:B").Value
.Item(R).Columns("F:G").Font.ColorIndex = K
.Cells(R, .Columns.Count) = 1
V(G)(M, 1) = V(G)(M, 1) - 1
Else
X(G) = 0: If X(1 - G) = 0 Then Exit For
End If
End If
Next
.Item(L & ":" & .Count).Sort .Cells(L, .Columns.Count), 1, Header:=2
L = .Cells(Rows.Count, 3).End(xlUp)(2).Row
If L <= .Count Then ' #8 : last mentors to last mentees
.Item(L & ":" & .Count).Columns("E:G").Font.ColorIndex = K
For R = L To .Count
M = Application.Match(Application.Max(V(X(1))), V(X(1)), 0)
If V(X(1))(M, 1) Then V(X(1))(M, 1) = V(X(1))(M, 1) - 1 Else Exit For
.Item(R).Columns("C:D") = Rg(1).Parent.Rows(M).Columns("A:B").Value
Next
End If
.Columns(.Columns.Count).Clear
End With
Application.ScreenUpdating = True
Erase Rg, V
End Sub
.
| Mentee ID | Mentee Name | Mentor ID | Mentor Name | Programme | Gender | Code |
60001111 | Alleen | 13456789 | Handscomb | Matched | Matched | Matched |
60001113 | Harriett | 13456791 | Day | Matched | Matched | Matched |
60001114 | Hewitt | 13456792 | Dobbs | Matched | Matched | Matched |
60001115 | Harbert | 13456793 | Erat | Matched | Matched | Matched |
60001117 | Ailey | 13456795 | Speek | Matched | Matched | Matched |
60001118 | Hadlee | 13456796 | Stainer | Matched | Matched | Matched |
60001119 | Lukas | 13456797 | Brundall | Matched | Matched | Matched |
60001120 | Raddie | 13456798 | Myrick | Matched | Matched | Matched |
60001121 | Stace | 13456799 | Heibl | Matched | Matched | Matched |
60001123 | Glenna | 13456801 | MacQueen | Matched | Matched | Matched |
60001124 | Tiebold | 13456802 | Casel | Matched | Matched | Matched |
60001126 | Stanford | 13456804 | Jedrzejewsky | Matched | Matched | Matched |
60001128 | Joeann | 13456817 | Keeton | Matched | Matched | Matched |
60001130 | Godfrey | 13456808 | Gyrgorcewicx | Matched | Matched | Matched |
60001132 | Jessee | 13456810 | Ege | Matched | Matched | Matched |
60001133 | Tiffany | 13456811 | Ojeda | Matched | Matched | Matched |
60001134 | Debi | 13456812 | Konzelmann | Matched | Matched | Matched |
60001135 | Carina | 13456813 | Strettle | Matched | Matched | Matched |
60001138 | Moises | 13456816 | Saxby | Matched | Matched | Matched |
60001139 | Codie | 13456817 | Keeton | Matched | Matched | Matched |
60001140 | Josi | 13456818 | Dockwra | Matched | Matched | Matched |
