Como hacer un calendario anual para un cuadrante de personal

Te anexo la macro para guardar la fecha aunque exceda el máximo

'
Private Sub CommandButton1_Click()
'Por.Dante Amor
    Dim fec1 As Date, fec2 As Date
    '
    Set h4 = Sheets("TEMP")
    h4.Cells.Clear
    h3.Rows(3).Copy h4.Rows(1)
    '
    If ListBox1.ListIndex = -1 Then
        MsgBox "Selecciona un nombre"
        Exit Sub
    End If
    If ComboBox2 = "" Then
        MsgBox "Selecciona un tipo de descanso"
        ComboBox2.SetFocus
        Exit Sub
    End If
    'validar fechas
    fec1 = TextBox2 & "/" & Label7.Caption
    fec2 = TextBox3 & "/" & Label8.Caption
    If Not IsDate(fec1) Then
        MsgBox "Captura una fecha desde"
        TextBox2.SetFocus
        Exit Sub
    End If
    If Not IsDate(fec2) Then
        MsgBox "Captura una fecha Hasta"
        TextBox3.SetFocus
        Exit Sub
    End If
    If fec2 < fec1 Then
        MsgBox "La fecha Hasta tiene que ser mayor o igual a la fecha Desde"
        TextBox3.SetFocus
        Exit Sub
    End If
    '
    nombre = ListBox1.List(ListBox1.ListIndex, 0)
    grupo = ListBox1.List(ListBox1.ListIndex, 1)
    Set g = h2.Columns("A").Find(grupo, lookat:=xlWhole)
    If Not g Is Nothing Then
        wmax = h2.Cells(g.Row, "B")
    Else
        MsgBox "El grupo no se encontró en la hoja NOMBRES : " & grupo
        Exit Sub
    End If
    '
    Application.ScreenUpdating = False
    'VALIDA MAXIMO
    cuenta = 0
    j = 2
    For i = 2 To h2.Range("B" & Rows.Count).End(xlUp).Row
        'busca todos los nombres que pertenecen al grupo
        If h2.Cells(i, "B") = grupo Then
            n_nombre = h2.Cells(i, "A")
            'busca el nombre en hoja unica
            Set b = h3.Columns("A").Find(n_nombre, lookat:=xlWhole)
            If Not b Is Nothing Then
                fila = b.Row
                h3.Rows(fila).Copy
                h4.Rows(j).PasteSpecial xlValues
                j = j + 1
            End If
        End If
    Next
    '
    u4 = h4.Range("A" & Rows.Count).End(xlUp).Row
    With h4.Range(h4.Cells(j, "B"), h4.Cells(j, "NA"))
        .FormulaR1C1 = "=COUNTA(R2C:R[-1]C)"
    End With
    '
    For fecha = fec1 To fec2
        Set b = h4.Rows(1).Find(fecha, lookat:=xlWhole)
        If Not b Is Nothing Then
            col = b.Column
            If h4.Cells(j, col) + 1 > wmax Then
                res = MsgBox("Se alcanzó el número máximo de personas en la fecha : " & fecha & vbCr & vbCr & _
                              "Desea añadirlo igualmente?", vbYesNo + vbQuestion, "AVISO")
                If res = vbNo Then Exit Sub
            End If
        Else
            MsgBox "Fecha no encontrada : " & fecha
            Exit Sub
        End If
    Next
    '
    'si no se alcanzó el número máximo se guardan las fechas
    Set c = h3.Columns("A").Find(nombre, lookat:=xlWhole)
    If Not c Is Nothing Then
        fila = c.Row
        For fecha = fec1 To fec2
            Set b = h3.Rows(3).Find(fecha, lookat:=xlWhole)
            If Not b Is Nothing Then
                col = b.Column
                h3.Cells(fila, col) = ComboBox2.List(ComboBox2.ListIndex, 1)
            Else
                MsgBox "Fecha no encontrada : " & fecha
                Exit Sub
            End If
        Next
    Else
        MsgBox "nombre no existe"
        Exit Sub
    End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Periodo guardado"
End Sub

sal u dos, Dante Amor, no olvides valorar.