Holidays formatting Vba.

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

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