sbMostFrequentPairs (VBA)

Wed, 15 Jul 2026 09:35:00 +0100

Abstract

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:

Appendix – sbMostFrequentPairs Code

Please read my Disclaimer.

Option Explicit

Sub sbMostFrequentPairs(vNames As Variant, _
    vInputArea As Variant, _
    rOutput As Range)
'Source (EN): https://www.sulprobil.de/sbmostfrequentpairs_en/
'Source (DE): https://www.berndplumhoff.de/sbmostfrequentpairs_de/
'(C) (P) by Bernd Plumhoff  09-Nov-2019 PB V1.0

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

Download

Please read my Disclaimer.

SbMostFrequentPairs on Sulprobil

sbMostFrequentPairs (VBA)

Abstract

Appendix – sbMostFrequentPairs Code

Download