Popup Calendar gets smaller every use

You could change your code adding the lines shown in bold:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Application.Intersect(Range("c2,c17,c21,c23,c26,c29,c32,c35,c38"), Target) Is Nothing Then
        Calendar1.Left = Target.Left + Target.Width - Calendar1.Width
        Calendar1.Top = Target.Top + Target.Height
        Calendar1.Width = 190
        Calendar1.Height = 115
        Calendar1.Visible = True
        If Not IsDate(Target.Value) Then
            Calendar1.Value = Date
        Else
            Calendar1.Value = Target.Value
        End If
    ElseIf Calendar1.Visible Then Calendar1.Visible = False
    End If
End Sub