• 👏 Bienvenido a nuestra comunidad Excel

    ¿Todavía no estás registrado? 😲

    Registrate gratis aquí y podrás:

    💪 Hacer preguntas a los expertos
    ⬇️ Descargar ejemplos y plantillas
    🏅 
    Acceder a contenidos premium

Colorear dias festivos con Vba.

werc

New member
Buenas alguien que pueda ayudarme. Un amigo me ayudo con el código para hacer un calendario perpetuo, el código colorea el primer día de cada mes pero también necesito que coloree los días festivos. gracias aqui mando el codigo del modulo mas la planilla gracias....
Código:
Option Explicit
Option Base 1

Sub crear_calendario()

Application.DisplayAlerts = False
    ActiveWorkbook.Save
Application.DisplayAlerts = True
    Hoja1.Select
    
    If Not IsDate([FecIni]) Then
        MsgBox "Introduce la fecha inicial"
        Range("FecIni").Select
        End
    End If
    
     If Val([qSemanas]) = 0 Then
        [qSemanas] = 6
    End If
   
    
    If Val([SemIni]) = 0 Then
        [SemIni] = [qSemanas] - 1
    End If
    
    If Val([SemIni]) > [qSemanas] Then
        [SemIni] = [qSemanas] - 1
    End If
    
    
    
Dim mes%, año%, fec&, semana%, m(), n%, fila%, colu%
ReDim m(366 + [qSemanas] * 7, 6)
        mes = Month([FecIni])
        año = Year([FecIni])
          n = Weekday(CDate("1/1/" & año), vbMonday) + 7 * ([SemIni] - 1)
       fila = 1
    For fec = [FecIni] To CDate("31/" & 12 & "/" & año)
        colu = IIf(n Mod [qSemanas] * 7 = 0, [qSemanas] * 7, n Mod [qSemanas] * 7)
        
        If colu = 1 Then
            fila = fila + 1
        End If
        
        semana = Application.WorksheetFunction.WeekNum(fec, vbMonday)
'        If semana >= [SemIni] Then
            m(n, 1) = fila
            m(n, 2) = colu
            m(n, 3) = semana
            m(n, 4) = Weekday(fec, vbMonday)
            m(n, 5) = fec
            If Day(fec) = 1 Then
                m(n, 6) = "'" & Month(fec) & "/" & Day(fec)
            Else
                m(n, 6) = "'" & Day(fec)
            End If
'        End If
        n = n + 1
    Next
    
    ho.Columns("A:G").Clear
    ho.Cells(1, 1).Resize(n, 6) = m
    ho.Cells(1, 4).Resize(n).NumberFormat = "General"
    ho.Cells(1, 5).Resize(n).NumberFormat = "dd/mm/yyyy ddd"
'    ho.Select
    fila = 1
    Do
        If ho.Cells(fila, 1) = "" Then
            fila = fila + 1
        Else
            Exit Do
        End If
    Loop
    ho.Cells(fila, 1).CurrentRegion.Name = "DATOSrAÑO"
    rellenar_rAÑO
End Sub

Sub rellenar_rAÑO()

BORRAR_rAÑO

MsgBox "Forsätta ..."
Application.ScreenUpdating = False
Dim r As Range, fr%
Dim s As Range, ss As Range
Dim fila%, colu%, dia$
    Set r = Range("DATOSrAÑO")
    Set s = Range("=D7:AE22")
        s.NumberFormat = "@"
        s.ClearContents
        Call quitar_color(s)
    For fr = 1 To r.Rows.Count
        fila = r(fr, 1)
        colu = r(fr, 2)
         dia = r(fr, 6)
        s(fila, colu) = dia
        If InStr(1, dia, "/", vbTextCompare) Then
            Set ss = s(fila, colu)
            Call poner_color(ss)
        End If
    Next
Application.ScreenUpdating = True

End Sub
Sub quitar_color(s)
    
    With s.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub
Sub BORRAR_rAÑO()
    
    With Range("=D7:AE22").Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
        Range("=D7:AE22").ClearContents

End Sub


Sub poner_color(ss)

    With ss.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub

Sub skrivaut4v()
'
' skrivaut5v Makro
'

'
    Range("D1:AF38").Select
    ActiveSheet.PageSetup.PrintArea = "$D$1:$AF$38"
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
End Sub

Sub SKAPAPDF4V()
'
' SKAPAPDF5V Makro
'

'
    Range("B3").Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "4semanas.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        True
End Sub
 

Adjuntos

Antoni

Well-known member
He añadido la llamada a la macro adjunta al final del procedimiento que calcula el formulario.
Los formatos condicionales prevalecen sobre el coloreado del día festivo, si prefieres que sea al contrario, hay que modificar la macro.
Código:
Sub ColorearFestivos()
For Each festivo In Range("D25:D38,O25:O38")
   If IsDate(festivo) Then
      Set fecha = ho.Columns("E").Find(festivo)
      If Not fecha Is Nothing Then
         días = fecha - (ho.Range("E3") - ho.Range("D3"))
         r = (días Mod 28)
         fila = (días - r) / 28 + 7
         columna = r + 3
         Cells(fila, columna).Interior.Color = vbCyan
      End If
   End If
Next
End Sub
 

Adjuntos

Arriba