Option Explicit
Public Sub Grunddaten()
On Error Resume Next
'Warnung abschalten, wichtig für MergedCells
Application.DisplayAlerts = False

Dim dtAnfang As Date
Dim dtEnde As Date
Dim iAnzTage%
Dim strBVH$, strProjektNR$, strKostenstelle$
Dim iC%, iVar1%, iVar2%

'später Abfrage über Inputboxen bzw. Userform
dtAnfang = "01.01.2010"
dtEnde = "01.06.2010"
iAnzTage = dtEnde - dtAnfang + 2

'später Abfrage über Inputboxen bzw. Userform
strBVH = "TEST-Projekt"
strProjektNR = "PNr-123456789"
strKostenstelle = "123456789"

'###Schleife um das Kalendarium zu erzeugen
'Zelle F3 = Anfangsdatum
Cells(3, 6).Value = dtEnde

'von Zeile 4 bis Anzahl der Tage (+1)
For iC = 4 To iAnzTage + 1
    'Spalte F ist das Datum im Klarformat
    With Cells(iC, 6)
        .Value = CDate(Cells(iC - 1, 6).Value - 1)
        .NumberFormat = "dd.mm.yyyy"
    End With
    'Spalte E ist der Wochentag (Mon, Di, Mi...)
    With Cells(iC, 5)
        .FormulaR1C1 = "=WEEKDAY(RC[1],1)"
        .NumberFormat = "ddd"
    End With
    'Spalte D ist die KW
    With Cells(iC, 4)
        .FormulaR1C1 = "=WEEKNUM(RC[2],2)"
        .NumberFormat = "0"
    End With
    'Spalte C ist der Monat, ACHTUNG hier unerwartete Schwierigkeiten bei der Formelauswertung
    With Cells(iC, 3)
        .FormulaR1C1 = "=RC[3]" '=MONTH(RC[3]) gibt hier den Monat bezogen auf den Tag aus ??
        .NumberFormat = "mmm"
    End With
    'Spalte B ist das Jahr
    With Cells(iC, 2)
        .FormulaR1C1 = "=RC[4]" '=YEAR(RC[4]) gibt hier das Jahr falsch aus ??
        .NumberFormat = "yyyy"
    End With
Next iC
'Zeile 3 AutoAusfüllen
Range("B4:E4").AutoFill Destination:=Range("B3:E4"), Type:=xlFillDefault
        
'Spalten B-E Schrift 90° + Rahmen
        With Range(Cells(3, 4), Cells(iAnzTage + 1, 5))
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 90
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .Borders.Weight = xlThin
            .BorderAround(, xlThick, xlColorIndexAutomatic) = True
            .EntireColumn.AutoFit
        End With

'Spalte C MONATE: Zellen zusammenfassen
iVar1 = 3
For iC = 4 To iAnzTage + 2
    If (Month(Cells(iC, 3)) <> Month(Cells(iC - 1, 3)) Or Cells(iC, 3).Value = "") Then
        iVar2 = iC - 1
        With Range(Cells(iVar1, 3), Cells(iVar2, 3))
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 90
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
            .BorderAround(, xlThick, xlColorIndexAutomatic) = True
            .EntireColumn.AutoFit
        End With
        iVar1 = iVar2 + 1
    End If
Next iC

'Spalte B JAHRE: Zellen zusammenfassen
iVar1 = 3
For iC = 4 To iAnzTage + 2
    If (Year(Cells(iC, 2)) <> Year(Cells(iC - 1, 2)) Or Cells(iC, 2).Value = "") Then
        iVar2 = iC - 1
        With Range(Cells(iVar1, 2), Cells(iVar2, 2))
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 90
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
            .BorderAround(, xlThick, xlColorIndexAutomatic) = True
            .EntireColumn.AutoFit
        End With
        iVar1 = iVar2 + 1
    End If
Next iC

'Spalte D: KW Zellen zusammenfassen
iVar1 = 3
For iC = 4 To iAnzTage + 2
    If (Cells(iC, 4) <> Cells(iC - 1, 4) Or Cells(iC, 4).Value = "") Then
        iVar2 = iC - 1
        With Range(Cells(iVar1, 4), Cells(iVar2, 4))
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 90
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
            .BorderAround(, xlThick, xlColorIndexAutomatic) = True
            .EntireColumn.AutoFit
        End With
        iVar1 = iVar2 + 1
    End If
Next iC

'Spaltenbreite optimieren

Columns(6).EntireColumn.AutoFit


'Warnung wieder einschalten
Application.DisplayAlerts = True
End Sub