Option Explicit

Function sbBirthdayList(r As Range) As Variant
'Create monthly birthday list.
'Source (EN): https://www.sulprobil.de/sbbirthdaylist_en/
'Source (DE): https://www.berndplumhoff.de/sbbirthdaylist_de/
'(C) (P) by Bernd Plumhoff 15-Sep-2010 PB V0.10
Dim vR(1 To 13, 1 To 3) As Variant
Dim i As Long, j As Long
Dim sNames(101 To 1231) As String

'Fill temporary array
For i = 1 To r.Rows.Count
    If IsDate(r.Cells(i, 2)) Then
        j = Month(r.Cells(i, 2))
        vR(j + 1, 2) = vR(j + 1, 2) + 1 'Increasing DOB counter for month
        j = j * 100 + Day(r.Cells(i, 2))
        If sNames(j) <> "" Then sNames(j) = sNames(j) & ", "
        sNames(j) = sNames(j) & r.Cells(i, 1)
    End If
Next i

'Fill output area
vR(1, 1) = "Month"
vR(1, 2) = "#"
vR(1, 3) = "(Day) Names"
For i = 1 To 12
    vR(i + 1, 1) = Format(DateSerial(1900, i, 1), "MMMM")
    vR(i + 1, 3) = ""
    For j = 1 To 31
        If sNames(i * 100 + j) <> "" Then
            If vR(i + 1, 3) <> "" Then vR(i + 1, 3) = vR(i + 1, 3) & ", "
            vR(i + 1, 3) = vR(i + 1, 3) & "(" & j & ") " & sNames(i * 100 + j)
        End If
    Next j
Next i

sbBirthdayList = vR

End Function