Option Explicit
'Calendario en Excel by htorres - Mikel ERP
'November 23, 2019
'Maracaibo , Venezuela
Sub SetCalHernan()
Const rStartDate As String = "C5"
'Const rNumWeeks As String = "B1" 'para mi esto representa la cantidad de filas en las que deseas tener tu calendario
Const rCalAnchor As String = "B7"
Const Color1 As Long = 65531
Const Color2 As Long = 16777215
Const rDiasSem As Integer = 7 'se conoce pero para controlar los parametros la dejo aqui
Dim i As Integer, fillColor As Long
Dim wd As Integer, d As Integer, w As Integer
Dim oStartDate As Range, oNumWeeks As Range
Dim oCalAnchor As Range ', dCalStart As Date esto na hace falta en mi idea
Dim rSemanas As Integer 'Columnas de semana
Dim pStartWeek As Integer
Dim pCalendarWidth As Integer
Dim calendarLines As Integer
Dim pLastWeek As Integer
Dim wColumnas As Integer
Dim pLastDay As Integer
Application.ScreenUpdating = False 'esto debe ir al principio
rSemanas = Range("rQtySemanas") 'puedes dirigir esto hacia una celda
pStartWeek = 2 'puedes asiganar esto a una celda. Asigno 2 para que inicie en Lunes
If IsDate(Range(rStartDate)) Then
Set oStartDate = Range(rStartDate) 'tengo que revisar sel formato de esta fecha
Else
MsgBox "Invalid Start Date"
Exit Sub
End If
' If IsNumeric(Range(rNumWeeks).Value) _
' And Range(rNumWeeks).Value > 0 Then
' Set oNumWeeks = Range(rNumWeeks)
' Else
' MsgBox "Invalid # of weeks" 'esto no hace falta
' Exit Sub
' End If
'Set oCalAnchor = Range(rCalAnchor) 'con esto entiendo que quieres borrar todo el rango antes de rellenarlo
'With oCalAnchor.CurrentRegion
Range("semanas").Select
With Selection
.ClearContents
.Interior.Pattern = xlNone
End With
'Esta sentencia deberia ser para colocar los encabezados de las columnas
'---CREANDO LOS ENCABEZADOS---
Range(oStartDate.Address).Offset(1, 1).Activate 'tomar una posicion para construir el calendario
'ActiveCell.Offset(1, 1).Activate
pCalendarWidth = (rDiasSem * rSemanas) - 1
For i = 0 To pCalendarWidth
'si deseas que tu calendario inicie con el dia de semana correspondiente
'puedes extender la idea que viene en la siguiente linea de codigo
'ActiveCell.Offset(0, i) = StrConv(Left(Format(Weekday(oStartDate + i, 2), "ddd"), 1), 1)
ActiveCell.Offset(0, i) = StrConv(Left(Format(Weekday(oStartDate - Weekday(oStartDate, 2) + i + 2, 2), "ddd"), 1), 1)
Next i
wd = Weekday(oStartDate, pStartWeek)
Range(oStartDate.Address).Offset(2, wd).Activate
'---ESCRIBIR UN CALENDARIO CON SEIS SEMANAS ANTES DE CADA SALTO---
'calcular las lineas ncesarias para completar
'el calendario hasta el 31-dic de cada año
'considerando las semanas requeridas
calendarLines = Application.WorksheetFunction.Quotient(365, (rDiasSem * rSemanas))
pLastWeek = calendarLines + 1
For w = 1 To pLastWeek
'---ESCRIBIR LOS DIAS---
Select Case w
Case 1 'si estamos en la primera semana del rango
Range(oStartDate.Address).Offset(2, wd).Activate
wColumnas = pCalendarWidth - (wd - 1)
For d = 0 To wColumnas
If Day(oStartDate + d) = 1 Then
'MsgBox "estoy en dia 1"
ActiveCell.Offset(0, d) = oStartDate + d
ActiveCell.Offset(0, d).NumberFormat = "m/d"
Else
ActiveCell.Offset(0, d) = oStartDate + d
ActiveCell.Offset(0, d).NumberFormat = "d"
End If
If Month(oStartDate + d) Mod 2 Then
ActiveCell.Offset(0, d).Interior.Color = Color1
Else
ActiveCell.Offset(0, d).Interior.Color = Color2
End If
Next d
Case pLastWeek
Range(oStartDate.Address).Offset(2 + w - 1, 1).Activate
wColumnas = bisiesto(Year(oStartDate)) - pLastDay - 1
For d = 0 To wColumnas
If Day(oStartDate + pLastDay) = 1 Then
ActiveCell.Offset(0, d) = oStartDate + pLastDay
ActiveCell.Offset(0, d).NumberFormat = "m/d"
Else
ActiveCell.Offset(0, d) = oStartDate + pLastDay
ActiveCell.Offset(0, d).NumberFormat = "d"
End If
If Month(oStartDate + pLastDay) Mod 2 Then
ActiveCell.Offset(0, d).Interior.Color = Color1
Else
ActiveCell.Offset(0, d).Interior.Color = Color2
End If
pLastDay = pLastDay + 1
Next d
Case Else
Range(oStartDate.Address).Offset(2 + w - 1, 1).Activate
For d = 0 To pCalendarWidth
If Day(oStartDate + pLastDay) = 1 Then
ActiveCell.Offset(0, d) = oStartDate + pLastDay
ActiveCell.Offset(0, d).NumberFormat = "m/d"
Else
ActiveCell.Offset(0, d) = oStartDate + pLastDay
ActiveCell.Offset(0, d).NumberFormat = "d"
End If
If Month(oStartDate + pLastDay) Mod 2 Then
ActiveCell.Offset(0, d).Interior.Color = Color1
Else
ActiveCell.Offset(0, d).Interior.Color = Color2
End If
pLastDay = pLastDay + 1
Next d
End Select
Select Case w
Case 1
pLastDay = d
Case pLastWeek
'no hago nada, porque he llegado al final
Case Else
pLastDay = pLastDay
End Select
Next w
Range("C15").Activate
Application.ScreenUpdating = True 'debemos devolver este estado a True
MsgBox "Calendario creado!!!", vbInformation, "Mikel ERP by htorres"
End Sub
Public Function bisiesto(anio As Integer)
Dim mesFeb As Date
Dim mesEvaluado As Integer
mesFeb = DateValue(Format("03/01/" & anio, "mm/dd/yyyy"))
mesEvaluado = Day(Application.EoMonth(mesFeb, -1))
If mesEvaluado = 28 Then
bisiesto = 365
Else
bisiesto = 366
End If
End Function
