Calender 6 semanas

Alexrr

New Member
Joined
Aug 30, 2019
Messages
10
Buenas ..
Tengo un Calendario de 6 semanas y al cambiar la fecha celda "C5" me da un nuevo agenda, notar que el 1 de enero del 2019 cae en la celda "E8" que es el día martes. El primer día de cada año varia dependiendo del año por ejemplo: 2020 cae el día miércoles "F8".
Lo que necesito es:
1- Formatear de modo que borre los días anteriores al año (2019 celdas "D7" hasta "D8") y al final del año (2019 celdas "AH16" hasta "AS16")

2- Marcar el primer día de cada mes ... por ejemplo 1 de enero 2019 seria: 1/1, 1 de Feb 2019 seria: 2/1, 1 de Marzo seria: 3/1, actualmente los meses se differencian de color amarillo y blanco

3- Poder cambiar que el Calendario (el 1 día de cada año) pueda empezar en la 1 semana, segunda, tercera semana, hasta la sexta semana. Utilizar la celda "C6" para este objetivo. ejemplo: Si pongo en la celda "C6" 4 cuarta semana, debería el Calendario empezar en la cuarta semana celda "Z8" para el año 2019

schemmaexcel

calendario6sem.jpg
 

hernantorres23

Board Regular
Joined
Nov 21, 2019
Messages
81
Office Version
365, 2016
Platform
Windows, Web
Saludos, no adjuntaste tu archivo correctamente, por lo tanto no he podido ayudarte
 

Alexrr

New Member
Joined
Aug 30, 2019
Messages
10
aquí te mando la modul..

Sub SetCal22()
Const rStartDate As String = "C5"
Const rNumWeeks As String = "B1"
Const rCalAnchor As String = "B7"
Const Color1 As Long = 65531
Const Color2 As Long = 16777215
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
If IsDate(Range(rStartDate)) Then
Set oStartDate = Range(rStartDate)
Else
MsgBox "Invalid Start Date"
Exit Sub
End If
If IsNumeric(Range(rNumWeeks)) _
And Range(rNumWeeks) > 0 Then
Set oNumWeeks = Range(rNumWeeks)
Else
MsgBox "Invalid # of weeks"
Exit Sub
End If
Set oCalAnchor = Range(rCalAnchor)
With oCalAnchor.CurrentRegion
.ClearContents
.Interior.Pattern = xlNone
End With
Application.ScreenUpdating = False
For i = 1 To 42 ' AQUI CAMBIE "0 To 6, para que comience con lunes y no domingo"
oCalAnchor.Offset(, oCalAnchor.Column + i - 1) = Format(i + 1, "ddd")
Next i
wd = Weekday(oStartDate)
dCalStart = DateSerial(Year(oStartDate), Month(oStartDate), Day(oStartDate)) - (wd - 1)
For w = -1 To oNumWeeks - 1
For d = 1 To 42 ' AQUI CAMBIE "0 To 6, para que comience con lunes y no domingo"
oCalAnchor.Offset(w + 1, oCalAnchor.Column + d - 1) = dCalStart + d + (w * 42) ' AQUI CAMBIE (w * 7)para 6 semanas 7*6=42
oCalAnchor.Offset(w + 1, oCalAnchor.Column + d - 1).NumberFormat = "d"
If Month(oCalAnchor.Offset(w + 1, oCalAnchor.Column + d - 1)) Mod 2 Then
fillColor = Color1
Else
fillColor = Color2
End If
oCalAnchor.Offset(w + 1, oCalAnchor.Column + d - 1).Interior.Color = fillColor
If d = 6 And Day(oCalAnchor.Offset(w + 1, oCalAnchor.Column + d - 1)) < 8 _
Or (Day(oCalAnchor.Offset(w + 1, oCalAnchor.Column + d - 1)) = Day(dCalStart) + 6 _
And Month(dCalStart) = Month(oCalAnchor.Offset(w + 1, oCalAnchor.Column + d - 1))) Then

' AQUI MUESTRA EL MES EN LA VERSION ORIGINAL
'
'oCalAnchor.Offset(w + 1, oCalAnchor.Column + d).NumberFormat = "@"
'oCalAnchor.Offset(w + 1, oCalAnchor.Column + d) = _
'Format(oCalAnchor.Offset(w + 1, oCalAnchor.Column + d - 1), "mmmm yyyy")
End If
Next d
Next w
End Sub
 

hernantorres23

Board Regular
Joined
Nov 21, 2019
Messages
81
Office Version
365, 2016
Platform
Windows, Web
He comenzado ha revisar tu archivo.
 

hernantorres23

Board Regular
Joined
Nov 21, 2019
Messages
81
Office Version
365, 2016
Platform
Windows, Web
Creo que con esto he cubierto, dos de los tres cosas que pides. La tercera no la he entendido bien y por eso no la he trabajado, ya que a mover el inicio de la semana,
no le he captado el beneficio.

Para probar puedes:
  1. Cambiar el numero en rQtySemanas
  2. Cambiar la fecha en rStartDate, puede comenzar en fechas distintas al 01/01
  3. No hace falta el numero en rNumWeeks
  4. ... y presiona el boton OK
Como vez, no he buscado borrar lo que ya estaba escrito, sino que preferi, aprovechar el bucle para no escribir las fechas que no correspondian al año

Dejo el codigo aca publicado, por si acaso le pueda servir a otro. Tiene varios bucles anidados, pero la verdad se ejecuta muy bien y con pocos recursos.
En el adjunto deje algunas notas, cualquier cosa estoy a la orden.

Si tienes algun problema con el idioma español, me avisas, aunque veo que escribes muy bien. De donde eres?

VBA Code:
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
 

Alexrr

New Member
Joined
Aug 30, 2019
Messages
10
Gracias por tu excelente trabajo. También me soluciona otro problema que era cuando tengo esquemas de trabajo de 4-6-8 semanas, montón de gracias.....

La 3 pregunta tú escribes "La tercera no la he entendido bien y por eso no la he trabajado, ya que a mover el inicio de la semana, no le he captado el beneficio."

El problema es que si yo tengo un esquema de trabajo y el último día del año termina un día martes(Fig:1) año2019

El año 2020 tiene que empezar el nuevo calendario un día miércoles (Fig:2). por la sencilla razon que el esquema de trabajo se repite.

esquema6semanas2019.gif
 

Attachments

Forum statistics

Threads
1,077,779
Messages
5,336,253
Members
399,072
Latest member
abublitz

Some videos you may like

This Week's Hot Topics

Top