Kallender
11.01.2018 06:20:00
Johann
ich habe diesen Kallender im Beispielarchiv gefunden
und finde diesen genial. Könnte jemand aber diesen Code
etwas abändern bitte?
1: Ich möchte nicht das eine neue Mappe erstellt wird sondern
im selben Workbook die Datumsangaben neu berechnet.
2: Das Datum zu jedem Monat steht in E1:AI1 in den Sheets 2-13
Option Explicit
Sub Main()
Dim wks As Worksheet
Dim cmt As Comment
Dim vYear As Variant
Dim iRow As Integer
Dim bln As Boolean
Application.ScreenUpdating = False
bln = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set wks = ActiveSheet
vYear = InputBox( _
prompt:="Gewünschtes Kalenderjahr angeben:", _
Default:=Year(Date))
Range("C1").Value = CInt(vYear)
Workbooks.Add 1
Call MonateAnlegen
Call TageEintragen
iRow = 1
Do Until IsEmpty(wks.Cells(iRow, 1))
With Worksheets(Month(wks.Cells(iRow, 2).Value))
With .Cells(Day(wks.Cells(iRow, 2).Value), 1)
.Interior.ColorIndex = 36
Set cmt = .AddComment(wks.Cells(iRow, 1).Value)
cmt.Shape.TextFrame.AutoSize = True
End With
End With
iRow = iRow + 1
Loop
Application.DisplayStatusBar = bln
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Private Sub MonateAnlegen()
Dim iMonth As Integer
For iMonth = 1 To 12
If iMonth > 1 Then
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
End If
ActiveSheet.Name = Format( _
DateSerial(Range("C1").Value, iMonth, 1), "mmmm")
Next iMonth
End Sub
Private Sub TageEintragen()
Dim wks As Worksheet, wksMy As Worksheet
Dim lDay As Long
Dim iMonth As Integer, iDay As Integer
Set wksMy = ThisWorkbook.Worksheets("Feiertage")
For iMonth = 1 To 12
Set wks = Worksheets(iMonth)
Application.StatusBar = "Bearbeite Monat " & wks.Name
wks.Columns(1).NumberFormat = "dd.mm.yy"
wks.Columns(2).NumberFormat = "dddd"
For lDay = DateSerial(wksMy.Range("C1").Value, iMonth, 1) To _
DateSerial(wksMy.Range("C1").Value, iMonth + 1, 0)
iDay = iDay + 1
wks.Cells(iDay, 1) = lDay
wks.Cells(iDay, 2) = lDay
If WeekDay(lDay) = 7 Then
wks.Cells(iDay, 1).Interior.ColorIndex = 34
wks.Cells(iDay, 2).Interior.ColorIndex = 34
ElseIf WeekDay(lDay) = 1 Then
wks.Cells(iDay, 1).Interior.ColorIndex = 35
wks.Cells(iDay, 2).Interior.ColorIndex = 35
End If
Next lDay
iDay = 0
Next iMonth
Worksheets(1).Select
ActiveWindow.Caption = "Jahreskalender " & wksMy.Range("C1").Value
End Sub