inserts months as sheet / pages Specifies days in detail Free Excel Macros (VBA) | Excel Programs

'For online Excel courses click: https://www.excelsizeyeter.com/excelwithkenan.com/udemy_giris.php

Sub Jahreskalender()
Dim strJahr As String
Dim lngNumSheets As Long
Dim intI As Integer, intJahr As Integer

strJahr = InputBox("Kalender anlegen für Jahr:", , Year(Date))
If strJahr = "" Or Not IsNumeric(strJahr) Then Exit Sub
intJahr = CInt(strJahr)

lngNumSheets = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 12
Workbooks.Add
Application.SheetsInNewWorkbook = lngNumSheets
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Windows(1).Caption = "Jahreskalender " & strJahr

For intI = 1 To 12
Worksheets(intI).Activate
Call MonatAnlegen(intJahr, intI)
Next intI

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Private Sub MonatAnlegen(intJahr As Integer, intMonat As Integer)
Dim intI As Integer
Dim lngDate As Long

lngDate = CLng(DateSerial(intJahr, intMonat, 1))
ActiveSheet.Name = Format(lngDate, "mmmm") 'zB "Januar"

Range("A1") = "Datum"
Range("C1") = "Eintragung"
Range("D1") = "Geburtstage"
With Range("A1:D1")
With .Font
.Bold = True
.Size = 10
.ColorIndex = 6
End With
.Interior.ColorIndex = 11
End With

intI = DateSerial(intJahr, intMonat + 1, 1) - lngDate + 1
Range("A2") = lngDate
Range("A3").Formula = "=A2+1"
Range("A3:A" & intI).FillDown
Range("A2:A" & intI).Copy
Range("A2:A" & intI).PasteSpecial (xlValues)
Range("A2:A" & intI).NumberFormat = "dd.mm.yy"
Columns(1).Copy Columns(2)
Range("B1") = "Tag"
Range("B1").HorizontalAlignment = xlRight
Range("B2:B" & intI).NumberFormat = "dddd" 'zB "Samstag"

Range("C2").Select
intI = 2
Do Until IsEmpty(Cells(intI, 1))
Select Case Weekday(Cells(intI, 1))
Case vbSaturday
Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 40 'Orange
Case vbSunday
Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 3 'Rot
End Select
Cells(intI, 3).Value = Feiertag(Cells(intI, 1).Value)
intI = intI + 1
Loop
ActiveSheet.UsedRange.Columns.AutoFit
End Sub

'http://home.t-online.de/home/t.igel/xlostern.htm
Private Function Feiertag(datum As Long) As String
Dim temp As Variant
Feiertag = ""
Select Case Month(datum)
Case 1
Select Case Day(datum)
Case 1
Feiertag = "Neujahr"
Case 6
Feiertag = "Heiligen 3 Könige"
End Select
Case 2 To 6
osSo = OsterSo(Year(datum))
Select Case datum
Case osSo - 48
Feiertag = "Rosenmontag"
Case osSo - 47
Feiertag = "Fasching"
Case osSo - 46
Feiertag = "Aschermittwoch"
Case osSo - 2
Feiertag = "Karfreitag"
Case osSo - 1
Feiertag = "Karsamstag"
Case osSo
Feiertag = "Ostersonntag"
Case osSo + 1
Feiertag = "Ostermontag"
Case DateSerial(Year(datum), 5, 1)
Feiertag = "Tag der Arbeit"
Case osSo + 39
Feiertag = "Christi Himmelfahrt"
Case osSo + 48
Feiertag = "Pfingstsamstag"
Case osSo + 49
Feiertag = "Pfingstsonntag"
Case osSo + 50
Feiertag = "Pfingstmontag"
Case osSo + 60
Feiertag = "Fronleichnam"
End Select
Case 8
Select Case Day(datum)
Case 15
Feiertag = "Maria Himmelfahrt"
End Select
Case 10
Select Case Day(datum)
Case 3
Feiertag = "Tag der Dt. Einheit"
End Select
Case 11
temp = DateSerial(Year(datum), 12, 25)
Select Case datum
Case DateSerial(Year(datum), 11, 1)
Feiertag = "Allerheiligen"
Case (temp - Weekday(temp, vbMonday) - 32)
Feiertag = "Buß- und Bettag"
End Select
Case 12
Select Case Day(datum)
Case 24
Feiertag = "Heilig Abend"
Case 25
Feiertag = "1. Weihnachtsfeiertag"
Case 26
Feiertag = "2. Weihnachtsfeiertag"
Case 31
Feiertag = "Silvester"
End Select
End Select
End Function

Private Function OsterSo(jahr As Integer) As Variant
Dim d As Variant
d = (((255 - 11 * (jahr Mod 19)) - 21) Mod 30) + 21
OsterSo = DateSerial(jahr, 3, 1) + d + (d > 48) + _
6 - ((jahr + jahr  4 + d + (d > 48) + 1) Mod 7)
End Function
---------------------------------------------------
Ayları sayfa olarak ekler günleri ayrıntılı olarak belirtir
Option Explicit

Sub Kalender_erstellen()
  Dim i As Integer, x As Integer, alt As Integer
  Dim WS As Worksheet
  Dim Jahr As Integer
  Jahr = InputBox("Bitte Das Jahr 4-stellig eingeben", "Jahresabfrage", _
    IIf(Month(Date) > 9, Year(Date) + 1, Year(Date)))
  alt = Application.SheetsInNewWorkbook 'alt auslesen
  Application.SheetsInNewWorkbook = 13 'verändern
  Workbooks.Add
  Application.SheetsInNewWorkbook = alt 'zurücksetzen
  For i = 1 To 12
    Set WS = Worksheets(i)
    With WS.[a1:E3]
      .HorizontalAlignment = xlCenter
      .MergeCells = True
      .Font.Name = "Arial"
      .Font.Size = 20
      .Font.Bold = True
      .Font.Italic = True
      .NumberFormat = "mmmm yyyy"
    End With
    
    WS.[a1] = DateSerial(Jahr, i, 1)
    WS.Name = Format(WS.[a1], "MMMM")
    WS.[A5:A36].NumberFormat = "DDD DD.MM.YY"
    WS.Columns(5).HorizontalAlignment = xlRight
    'Datum eintragen
    For x = 0 To 30
      If Month(WS.[a1] + x) = Month(WS.Cells(x + 6, 1)) Or x = 0 Then
        WS.Cells(x + 7, 1) = WS.[a1] + x
        If Weekday(WS.Cells(x + 7, 1)) = 1 Then _
            Range(WS.Cells(x + 7, 1), WS.Cells(x + 7, 5)).Interior.ColorIndex = 48
        If Weekday(WS.Cells(x + 7, 1)) = 7 Then _
            Range(WS.Cells(x + 7, 1), WS.Cells(x + 7, 5)).Interior.ColorIndex = 15
        If Weekday(WS.Cells(x + 7, 1)) = 2 Then WS.Cells(x + 7, 5) = _
            "KW " & DatePart("ww", WS.Cells(x + 7, 1), vbMonday, vbFirstFourDays)
        WS.Cells(x + 7, 1).Borders.Weight = xlThin
        With Range(WS.Cells(x + 7, 2), WS.Cells(x + 7, 5))
          .Borders(xlEdgeLeft).Weight = xlThin
          .Borders(xlEdgeTop).Weight = xlThin
          .Borders(xlEdgeBottom).Weight = xlThin
          .Borders(xlEdgeRight).Weight = xlThin
        End With
        'Feiertage eintragen und formatieren
        WS.Cells(x + 7, 2) = FeiertagCH(WS.Cells(x + 7, 1))
        If WS.Cells(x + 7, 2)  "" Then
          If Right(WS.Cells(x + 7, 2), 1) = "*" And _
            WS.Cells(x + 7, 2).Interior.ColorIndex = xlNone Then
            Range(WS.Cells(x + 7, 1), WS.Cells(x + 7, 3)).Interior.ColorIndex = 15
          Else
            Range(WS.Cells(x + 7, 1), WS.Cells(x + 7, 5)).Interior.ColorIndex = 48
          End If
        End If
      End If
    Next x
  Next i
  
  With Worksheets(13)
    .Name = "Übersicht"
    .PageSetup.Orientation = xlLandscape
    With .Columns("A:F")
      .ColumnWidth = 19.5
      ' weitere Formatierungen der Spalten
    End With
    For i = 1 To 6
      .Cells(2, i) = Format(DateSerial(0, i, 1), "MMMM")
      .Cells(20, i) = Format(DateSerial(0, i + 6, 1), "MMMM")
      Range(.Cells(2, i), .Cells(19, i)).BorderAround ColorIndex:=0, Weight:=xlThin
      Range(.Cells(20, i), .Cells(38, i)).BorderAround ColorIndex:=0, Weight:=xlThin
    Next i
  End With
End Sub

Function FeiertagCH(datum As Date)
Dim J As Integer
Dim O As Date
Dim D As Integer
J = Year(datum)
D = (((255 - 11 * (J Mod 19)) - 21) Mod 30) + 21
O = DateSerial(J, 3, 1) + D + (D > 48) + 6 - _
  ((J + J  4 + D + (D > 48) + 1) Mod 7)
Select Case datum
    Case Is = DateSerial(J, 1, 1)
        FeiertagCH = "Neujahr"
    Case Is = DateSerial(J, 1, 2)
        FeiertagCH = "Berchtoldstag*"
    Case Is = DateSerial(J, 3, 3)
        FeiertagCH = "Josefstag*"
    Case Is = DateAdd("D", -2, O)
        FeiertagCH = "Karfreitag"
    Case Is = O
        FeiertagCH = "Ostersonntag"
    Case Is = DateAdd("D", 1, O)
        FeiertagCH = "Ostermontag*"
    Case Is = DateSerial(J, 5, 1)
        FeiertagCH = "Maifeiertag*"
    Case Is = DateAdd("D", 39, O)
        FeiertagCH = "Auffahrt, Christi Himmelfahrt"
    Case Is = DateAdd("D", 49, O)
        FeiertagCH = "Pfingstsonntag"
    Case Is = DateAdd("D", 50, O)
        FeiertagCH = "Pfingstmontag"
    Case Is = DateAdd("D", 60, O)
        FeiertagCH = "Fronleichnam*"
    Case Is = DateSerial(J, 8, 1)
        FeiertagCH = "Bundesfeier"
    Case Is = DateSerial(J, 8, 15)
        FeiertagCH = "Mariae Himmelfahrt*"
    Case Is = DateSerial(J, 11, 1)
        FeiertagCH = "Allerheiligen*"
    Case Is = DateSerial(J, 12, 8)
        FeiertagCH = "Mariae Empfängnis*"
    Case Is = DateSerial(J, 12, 24)
        FeiertagCH = "Heilig Abend*"
    Case Is = DateSerial(J, 12, 25)
        FeiertagCH = "Weihnachtsfeiertag"
    Case Is = DateSerial(J, 12, 26)
        FeiertagCH = "Stefanstag"
    Case Is = DateSerial(J, 12, 31)
        FeiertagCH = "Silvester*"
Case Else
    FeiertagCH = ""
End Select
End Function
B1127B1141 -

No	Macro Name
1	inserts months as sheet / pages Specifies days in detail
2	excel operators hk
3	summer adds months to sheet / pages
4	inserts sheet / pages as hyperlinks
5	specifies in detail how many formulas are in the book (on new sheet / page)
6	specifies in detail how many references the book contains (on new sheet / page)
7	inserts sequential (ascending) sheet / pages
8	automatic custom footer and header information on sheet / pages
9	if the sheet / page is blank, inserts the date in the footer and prints if not
10	Adds months as a sheet / page and writes the days of the month and goes to the active month and day
11	inserts double zeros at the beginning of numbers entered in specific cells on the active sheet / page
12	Adds sheet / pages based on data in column A and writes data up to column D
13	status bar macro with a message waiting
14	adds months as sheet / pages and goes to that day
15	add months as sheet / pages
16	insert date as left header when sheet / page is active
17	index sheet / pages of sheet / pages inserting graphic sheet / page with message
18	Add Multiple Worksheets: you can use this code if you want to add multiple worksheets in a single point in your workbook. When you run this macro code, you receive an input box to enter the total number of sheet / pages you want to enter.
19	a macro that automatically deletes the following month-old sheet / pages before moving to the new month when the specified month is over
20	inserts and deletes annotations with the date and time in the active sheet / page

Excel Free Macros (VBA)

İnserts Months As Sheet / Pages Specifies Days İn Detail

Online Excel Courses

Services

How can we help you?

Subscribe to our Youtube Channel?

Keywords