Calendario Visual Basic

[manuel1961]

os dejo un calendario perpetuo, echo con visual basic de excel, espero que os guste
Sub meses()
Dim numero As Integer


numero = Val(Range("a1"))
If numero = 1 Then Range("d6") = "ENERO"
If numero = 2 Then Range("d6") = "FEBRERO"
If numero = 3 Then Range("d6") = "MARZO"
If numero = 4 Then Range("d6") = "ABRIL"
If numero = 5 Then Range("d6") = "MAYO"
If numero = 6 Then Range("d6") = "JUNIO"
If numero = 7 Then Range("d6") = "JULIO"
If numero = 8 Then Range("d6") = "AGOSTO"
If numero = 9 Then Range("d6") = "SEPTIEMBRE"
If numero = 10 Then Range("d6") = "OCTUBRE"
If numero = 11 Then Range("d6") = "NOVIEMBRE"
If numero = 12 Then Range("d6") = "DICIEMBRE"

Call diasmes
End Sub
Sub diasmes()
Dim diames As Byte
Dim a As Byte
Dim fila As Byte
Dim columna As Byte
Dim diasemana As Byte
Dim año As Byte
Dim suma As Byte
Dim codigomes As Byte
Dim dia As Byte
Dim codigosemana As Byte

Range("d8:j13").ClearContents
fila = 8
If Range("a1") = 2 Then diames = 28
If Range("d5") Mod 4 = 0 Then diames = 29 ' año bisiesto
If Val(Range("a1")) = 1 Or Val(Range("a1")) = 3 Or Val(Range("a1")) = 5 Or Val(Range("a1")) = 7 Or Val(Range("a1")) = 8 Or Val(Range("a1")) = 10 Or Val(Range("a1")) = 12 Then diames = 31
If Val(Range("a1")) = 4 Or Val(Range("a1")) = 6 Or Val(Range("a1")) = 9 Or Val(Range("a1")) = 11 Then diames = 30


año = Int(Right(Range("d5"), 2) / 4)
sumar = Right(Range("d5"), 2) + año
GoSub codigo
diasemana = año + sumar + codigomes + 1
codigosemana = diasemana Mod 7

If codigosemana = 0 Then columna = 9
If codigosemana = 1 Then columna = 10
If codigosemana = 2 Then columna = 4
If codigosemana = 3 Then columna = 5
If codigosemana = 4 Then columna = 6
If codigosemana = 5 Then columna = 7
If codigosemana = 6 Then columna = 8

For a = 1 To diames
Cells(fila, columna) = a
If columna = 10 Then GoSub suma Else columna = columna + 1
Next a
Range("a1").Select
End
suma:
fila = fila + 1
columna = 4
Return
End

codigo:
numero = Val(Range("a1"))
If numero = 1 Then codigomes = 5
If numero = 2 Then codigomes = 1
If numero = 3 Then codigomes = 1
If numero = 4 Then codigomes = 4
If numero = 5 Then codigomes = 6
If numero = 6 Then codigomes = 2
If numero = 7 Then codigomes = 4
If numero = 8 Then codigomes = 7
If numero = 9 Then codigomes = 3
If numero = 10 Then codigomes = 5
If numero = 11 Then codigomes = 1
If numero = 12 Then codigomes = 3
Return


End Sub