ayları sayfa olarak ekler günleri ayrıntılı olarak belirtir Hazır Excel Makroları (VBA) | Excel Programları

Makroyu Kopyala

'Excel Makro (VBA) online eğitimleri için: https://www.excelsizeyeter.com/excelsizeyeter.com/udemy_giris.php adresine tıklayınız. Bir eğitim alana bir eğitim bedavadır. İkinci eğitim olarak Excel, Excel pratik çözümler, finans eğitimleri vb. alabilirsiniz.

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	Makro Adı
1	ayları sayfa olarak ekler günleri ayrıntılı olarak belirtir
2	ayları sayfa olarak ekler ayın günlerini de yazar ve aktif ay ve güne gider
3	ayları sayfa olarak ekler ve o güne gider
4	kitapta ne kadar refers varsa ayrıntılı olarak belirtir (yeni sayfada)
5	kitapta ne kadar formül varsa ayrıntılı olarak belirtir (yeni sayfada)
6	excelde kendi eklenti ve fonksiyonlarınızı oluşturun
7	Inputbox yılı yaz, ayları sayfa olarak eklesin
8	ayları sayfa olarak ekleme
9	yılı yaz sayfalara ayları ekler
10	aktif sayfada veri girilen hücrelere veri girildiği tarih ve saati açıklama olarak ekler
11	işgünlerine ait sheet açmak.
12	sayfaları köprü olarak ekler
13	Dosyayı kim açtı 2
14	Metin Sarmalamasını Kaldırma: Bu kod, tek bir tıklamayla tüm çalışma sayfasındaki metin sarma işlemini kaldırmanıza yardımcı olacaktır. Önce tüm sütunları seçer ve daha sonra metin kaydırmayı kaldırır ve tüm satırları ve sütunları otomatik olarak sığar.
15	belirtilen ay bittiğinde yeni aya geçmeden önce, aşağıdaki eski aya ait sayfaları otomatik olarak silecek bir makro
16	belirlediğim verilerin klasör, dosyaadi olarak kaydı
17	userform'u otomatik boyutlandırma
18	dosyayı kim açtı
19	menü olarak saat ekleme (en güvenilir)
20	dolaylı makro

Excel Hazır Makrolar (VBA)

Ayları Sayfa Olarak Ekler Günleri Ayrıntılı Olarak Belirtir

Robotik Kodlama

Hizmetler

Size nasıl yardımcı olabiliriz?

Youtube Kanalımıza Abone Oldunuz mu?

Anahtar Kelimeler