Sub test()
t = Timer
Set dict = CreateObject("scripting.dictionary")
dict.CompareMode = vbTextCompare
a = Sheets("james").Range("A1").CurrentRegion.Value2 'read to an array
mymin = Application.Min(Application.Index(a, 0, 2)) 'smallest
mymax = Application.Max(Application.Index(a, 0, 2)) 'greatest
Delta = WorksheetFunction.Round((mymax - mymin) / 30.5, 0) + 1 'number of months
s0 = "'" & WorksheetFunction.Rept("0", Delta) 'startstring
For i = 2 To UBound(a)
If Not dict.exists(a(i, 1)) Then dict.Add a(i, 1), Array(a(i, 1), s0) 'does name already exist in dict, if not add
it = dict(a(i, 1)) 'item for that name
j = WorksheetFunction.Round((a(i, 2) - mymin) / 30.5, 0) + 2 ' that month is character j in the string
it(1) = Left(it(1), j - 1) & "1" & Mid(it(1), j + 1) 'replace that char with a "1"
dict(a(i, 1)) = it 'write back to dict
Next
a = Application.Index(dict.items, 0, 0)
With Range("D2").ListObject
If .ListRows.Count Then .DataBodyRange.Delete
.ListRows.Add.Range.Range("A1").Resize(dict.Count, 2).Value = Application.Index(dict.items, 0, 0)
.Range.EntireColumn.AutoFit
End With
dict.RemoveAll
For i = 1 To UBound(a)
For j = 1 To Len(a(i, 2))
If Mid(a(i, 2), j, 1) = "0" Then dict.Add dict.Count, Array(a(i, 1), WorksheetFunction.EDate(mymin, j - 2))
Next
Next
a = Application.Index(dict.items, 0, 0)
With Range("G2").ListObject
If .ListRows.Count Then .DataBodyRange.Delete
.ListRows.Add.Range.Range("A1").Resize(dict.Count, 2).Value = Application.Index(dict.items, 0, 0)
.Range.EntireColumn.AutoFit
End With
MsgBox "done in " & Format(Timer - t, "0.0s")
End Sub
