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

  • esquemapregunta11.jpg
    esquemapregunta11.jpg
    113.6 KB · Views: 17

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

ebea

Board Regular
Joined
Jul 12, 2008
Messages
217
Office Version
  1. 2013
Platform
  1. 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
58,440
Office Version
  1. 365
Platform
  1. 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.

Watch MrExcel Video

Forum statistics

Threads
1,133,320
Messages
5,658,134
Members
418,429
Latest member
Regila

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top