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
Option Explicit
Sub sbMostFrequentPairs(vNames As Variant, _
vInputArea As Variant, _
rOutput As Range)
'Idea: https://www.ms-office-forum.net/forum/showthread.php?t=356473
'Reverse("moc.LiborPlus.www") 09-Nov-2019 PB V1.00 (C) (P) by Bernd Plumhoff
Dim vT As Variant
Dim i As Long, j As Long, k As Long
Dim sName As String
Dim state As SystemState
Set state = New SystemState
With Application.WorksheetFunction
'Get LBound und UBound address with vT(x, y):
vT = .Transpose(.Transpose(vInputArea))
For i = LBound(vT, 1) To UBound(vT, 1)
For j = LBound(vT, 2) To UBound(vT, 2)
If vT(i, j) = "x" Or vT(i, j) = "X" Then
vT(i, j) = 1
Else
'Detect non-empty other cells:
If vT(i, j) <> "" Then Debug.Print i, j, "'" & vT(i, j) & "'"
vT(i, j) = 0
End If
Next j
Next i
vT = .MMult(vT, .Transpose(vT)) 'This is the core calculation
Range(rOutput, rOutput.Offset(0, 2)).FormulaArray = _
Array("Rank", "Duo", "Frequency")
k = 1
For i = 2 To UBound(vT, 1)
For j = 1 To i - 1 'We just need the lower left triangular matrix
'Sort the names:
sName = vNames(i) & " & " & vNames(j)
If vNames(i) > vNames(j) Then sName = vNames(j) & " & " & vNames(i)
Range(rOutput.Offset(k, 0), rOutput.Offset(k, 2)).FormulaArray = _
Array("", sName, vT(i, j))
k = k + 1
Next j
Next i
'Sort by frequency and then by name
With rOutput.Worksheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rOutput.Worksheet.Range("C2:C" & k), _
Order:=xlDescending
.SortFields.Add Key:=rOutput.Worksheet.Range("B2:B" & k), _
Order:=xlAscending
.SetRange rOutput.Worksheet.Range("A1:C" & k)
.Header = xlYes
.Apply
End With
'Add the rank
k = 1
Do While Not IsEmpty(rOutput.Offset(k, 2))
If rOutput.Offset(k, 2) <> rOutput.Offset(k - 1, 2) Then
'Some fancy top border
With Range(rOutput.Offset(k, 0), _
rOutput.Offset(k, 2)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
rOutput.Offset(k, 0) = k
End If
k = k + 1
Loop
Range(rOutput.Offset(k, 0), _
rOutput.Offset(k, 2)).EntireColumn.AutoFit
End With
End Sub
Sub sbGenerateListOfPairs()
Dim state As SystemState
Set state = New SystemState
wsPairs.Cells.EntireRow.Delete
Call sbMostFrequentPairs(Range(wsPresent.Range("A3"), _
wsPresent.Range("A2").End(xlDown)), _
Range(wsPresent.Range("A2").End(xlDown).Offset(-1), _
wsPresent.Range("A2").End(xlToRight).Offset(0, -1)).Offset(1, 1), _
wsPairs.Range("A1"))
End Sub
Copy link