Sulprobil
Search…
sbMostFrequentPairs
This came up in a German Excel Forum: Given a matrix of some club members and when they attended a club evening, which member duo showed up most frequently at these club meetings?
The input in sheet wsPresent:
The output in sheet wsPairs:
The code:
Please read my Disclaimer
1
Option Explicit
2
3
Sub sbMostFrequentPairs(vNames As Variant, _
4
vInputArea As Variant, _
5
rOutput As Range)
6
'Idea: https://www.ms-office-forum.net/forum/showthread.php?t=356473
7
'Reverse("moc.LiborPlus.www") 09-Nov-2019 PB V1.00 (C) (P) by Bernd Plumhoff
8
9
Dim vT As Variant
10
Dim i As Long, j As Long, k As Long
11
Dim sName As String
12
Dim state As SystemState
13
14
Set state = New SystemState
15
16
With Application.WorksheetFunction
17
18
'Get LBound und UBound address with vT(x, y):
19
vT = .Transpose(.Transpose(vInputArea))
20
21
For i = LBound(vT, 1) To UBound(vT, 1)
22
For j = LBound(vT, 2) To UBound(vT, 2)
23
If vT(i, j) = "x" Or vT(i, j) = "X" Then
24
vT(i, j) = 1
25
Else
26
'Detect non-empty other cells:
27
If vT(i, j) <> "" Then Debug.Print i, j, "'" & vT(i, j) & "'"
28
vT(i, j) = 0
29
End If
30
Next j
31
Next i
32
33
vT = .MMult(vT, .Transpose(vT)) 'This is the core calculation
34
35
Range(rOutput, rOutput.Offset(0, 2)).FormulaArray = _
36
Array("Rank", "Duo", "Frequency")
37
k = 1
38
For i = 2 To UBound(vT, 1)
39
For j = 1 To i - 1 'We just need the lower left triangular matrix
40
'Sort the names:
41
sName = vNames(i) & " & " & vNames(j)
42
If vNames(i) > vNames(j) Then sName = vNames(j) & " & " & vNames(i)
43
Range(rOutput.Offset(k, 0), rOutput.Offset(k, 2)).FormulaArray = _
44
Array("", sName, vT(i, j))
45
k = k + 1
46
Next j
47
Next i
48
49
'Sort by frequency and then by name
50
With rOutput.Worksheet.Sort
51
.SortFields.Clear
52
.SortFields.Add Key:=rOutput.Worksheet.Range("C2:C" & k), _
53
Order:=xlDescending
54
.SortFields.Add Key:=rOutput.Worksheet.Range("B2:B" & k), _
55
Order:=xlAscending
56
.SetRange rOutput.Worksheet.Range("A1:C" & k)
57
.Header = xlYes
58
.Apply
59
End With
60
61
'Add the rank
62
k = 1
63
Do While Not IsEmpty(rOutput.Offset(k, 2))
64
If rOutput.Offset(k, 2) <> rOutput.Offset(k - 1, 2) Then
65
'Some fancy top border
66
With Range(rOutput.Offset(k, 0), _
67
rOutput.Offset(k, 2)).Borders(xlEdgeTop)
68
.LineStyle = xlContinuous
69
.Weight = xlThin
70
End With
71
rOutput.Offset(k, 0) = k
72
End If
73
k = k + 1
74
Loop
75
76
Range(rOutput.Offset(k, 0), _
77
rOutput.Offset(k, 2)).EntireColumn.AutoFit
78
79
End With
80
81
End Sub
82
83
Sub sbGenerateListOfPairs()
84
85
Dim state As SystemState
86
Set state = New SystemState
87
88
wsPairs.Cells.EntireRow.Delete
89
Call sbMostFrequentPairs(Range(wsPresent.Range("A3"), _
90
wsPresent.Range("A2").End(xlDown)), _
91
Range(wsPresent.Range("A2").End(xlDown).Offset(-1), _
92
wsPresent.Range("A2").End(xlToRight).Offset(0, -1)).Offset(1, 1), _
93
wsPairs.Range("A1"))
94
95
End Sub
Copied!
Last modified 1yr ago
Copy link