[kapetang]

Βάλε στο ενεργό φύλλο τον παρακάτω κώδικα:

Option Explicit
Const strSheet As String = "Φύλλο2"
Const startCel As String = "B4"     'αρχή των ημερομηνιών
Const startResult As String = "F3"  'αρχή αποτελεσμάτων
Const cboCel As String = "D2"       'κελί combobox


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngSource As Range, dct As Object, i As Long, key As Variant
    Dim D(1 To 6) As Long, M3 As Long, start3 As Date, end3 As Date
    Dim yr As Long, c As Range, d15 As Long, x() As Variant, sh As Worksheet
    
    On Error GoTo errHandler

    If Target.Count = 1 And Replace(Target.Address, "$", "") = cboCel Then
        Set sh = Worksheets(strSheet)
        Set rngSource = sh.Range(sh.Range(startCel), sh.Cells(Rows.Count, sh.Range(startCel).Column).End(xlUp))
        Set dct = CreateObject("Scripting.Dictionary")
        yr = Year(rngSource(1))
        M3 = Asc(Range(cboCel)) - 192
        start3 = DateSerial(yr, (M3 - 1) * 3 + 1, 1)
        end3 = DateSerial(yr, M3 * 3 + 1, 0)
        For Each c In rngSource
            If IsDate(c) Then
                If c >= start3 And c <= end3 Then
                    d15 = (Month(c) - M3 * 3 + 2) * 2 + IIf(Day(c) <= 15, 1, 2)
                    If Not dct.exists(c.Value) Then
                        dct(c.Value) = d15
                    End If
                End If
            End If
        Next
        Range(startResult).Resize(rngSource.Count, 6).ClearContents
        If dct.Count Then
            ReDim x(1 To dct.Count, 1 To 6) As Variant
            For Each key In dct.keys
                D(dct(key)) = D(dct(key)) + 1
                x(D(dct(key)), dct(key)) = key
            Next
            Range(startResult).Resize(dct.Count, 6).Value = x
        End If
    End If

    Exit Sub

errHandler:
    MsgBox Err.Description, vbCritical, "Error #" & Err.Number

End Sub

Στις 2 πρώτες Const βάλε το φύλλο και το πρώτο κελί με τις ημερομηνίες.