Formatear dias feriados VBA.

Status
Not open for further replies.

Alexrr

New Member
Joined
Aug 30, 2019
Messages
14
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 de Suecia. gracias aqui mando el codigo..

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

Attachments

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

ebea

Board Regular
Joined
Jul 12, 2008
Messages
202
Office Version
2010
Platform
Windows
Debe poner su pregunta en una sección diferente del foro, que está en un idioma que no sea inglés.
 

Alexrr

New Member
Joined
Aug 30, 2019
Messages
14
Hello someone who can help me. A friend helped me with the code to make a perpetual calendar, the code colors the first day of each month but I also need it to color the Swedish holidays. thanks here I send the code ..
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
44,505
Office Version
365
Platform
Windows
Duplicate Holidays formatting Vba.

Please do not post the same question multiple times. All clarifications, follow-ups, and bumps should be posted back to the original thread.
Per forum rules, posts of a duplicate nature will be locked or deleted (rule 12 here: Forum Rules).
 
Status
Not open for further replies.

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,105,931
Messages
5,508,188
Members
408,669
Latest member
AgsikapAko

This Week's Hot Topics

Top