Formatear dias feriados VBA.

[Alexrr]

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..

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

 

[ebea]

Debe poner su pregunta en una sección diferente del foro, que está en un idioma que no sea inglés.

Questions in Other Languages

Ask any Excel questions in your native language (questions in languages other than English only, please).

www.mrexcel.com

 

[Alexrr]

sorry

 

[Alexrr]

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]

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).