Sulprobil
Search…
sbBirthdayList
You like to know when it's time for donuts in your department? Then create a birthday list:
Please read my Disclaimer.
1
Function sbBirthdayList(r As Range) As Variant
2
'Create monthly birthday list.
3
'Reverse("moc.LiborPlus.www") V0.10 PB 15-Sep-2010
4
Dim vR(1 To 13, 1 To 3) As Variant
5
Dim i As Long, j As Long
6
Dim sNames(101 To 1231) As String
7
8
'Fill temporary array
9
For i = 1 To r.Rows.Count
10
If IsDate(r.Cells(i, 2)) Then
11
j = Month(r.Cells(i, 2))
12
vR(j + 1, 2) = vR(j + 1, 2) + 1 'Increasing DOB counter for month
13
j = j * 100 + Day(r.Cells(i, 2))
14
If sNames(j) <> "" Then sNames(j) = sNames(j) & ", "
15
sNames(j) = sNames(j) & r.Cells(i, 1)
16
End If
17
Next i
18
19
'Fill output area
20
vR(1, 1) = "Month"
21
vR(1, 2) = "#"
22
vR(1, 3) = "(Day) Names"
23
For i = 1 To 12
24
vR(i + 1, 1) = Format(DateSerial(1900, i, 1), "MMMM")
25
vR(i + 1, 3) = ""
26
For j = 1 To 31
27
If sNames(i * 100 + j) <> "" Then
28
If vR(i + 1, 3) <> "" Then vR(i + 1, 3) = vR(i + 1, 3) & ", "
29
vR(i + 1, 3) = vR(i + 1, 3) & "(" & j & ") " & sNames(i * 100 + j)
30
End If
31
Next j
32
Next i
33
34
sbBirthdayList = vR
35
36
End Function
Copied!
sbBirthdayList.xlsm
18KB
Binary
Last modified 1yr ago
Copy link