Office: Marko für Kalender umschreiben

Hallo Excel Freunde,

ich beschäftige mich zurzeit mit der Erstellung eines Kalenders.
Ich fand in Internet dieses Marko:

Option Explicit

Sub Kalender()
Dim intfrage As Integer
Dim monat As Integer
Dim LDay As Range
Application.ScreenUpdating = False
Cells.ClearContents
intfrage = InputBox("Welches Jahr?")
For monat = 1 To 12
Set LDay = Cells(10, (monat - 1) * 3 + 1).Resize(Day(DateSerial(intfrage, monat + 1, 0)))
Cells(10, (monat - 1) * 3 + 1) = DateSerial(intfrage, monat, 1)
LDay.DataSeries , xlChronological, xlDay
Next monat
Application.ScreenUpdating = True
End Sub

Ich finde diesen Marko sehr gut, da man mit der Bedingten Formatierung und Formeln weiter arbeiten kann.
Da ich aber kein VBA Profi bin möchte ich gern wissen wie man den Marko so umschreiben kann das ich zwischen den Tagen eine leere Zelle habe und zwischen den Monaten unterschiedlich viele Spalten habe.
Mit den unterschiedlichen Spalten könnte man ja so lösen,

Dim Zelle As Integer
Dim varSpaltArr As Variant
varSpaltArr = Array(2, 2, 3, 4, 3, 6,6,3,4, 2, 2, 2, 0)

Zelle = 1

Zelle = Zelle + varSpaltArr(monat - 1)

Wie gesagt ich bin kein Profi aber vielleicht kann mir hier einer helfen das alles zu kombinieren.

MfG sjbz500

 

Hallo,

folgendes Makro sollte Deine Ansprüche abdecken:

Code:

Sub Kalender()
    Dim intFrage As Integer
    Dim SpaltenArray As Variant
    Dim DatLfd As Date, NeuJahr As Date, Sylvester As Date
    Dim Zeile As Long, Spalte As Long
    
    On Error GoTo Err_Kalender
    intFrage = InputBox("Welches Jahr?")
    
    'Array der Spaltennummern für die Monate 1-12 (Jan=2, Feb=4, .., Dez=39)
    SpaltenArray = Array(0, 2, 4, 7, 11, 14, 20, 26, 29, 33, 35, 37, 39)
    
    Application.ScreenUpdating = False
    
    Cells.ClearContents
    
    NeuJahr = DateSerial(intFrage, 1, 1)
    Sylvester = DateSerial(intFrage + 1, 1, 1) - 1
    
    For DatLfd = NeuJahr To Sylvester
      Zeile = Day(DatLfd) * 2 + 8
      Spalte = SpaltenArray(Month(DatLfd))
      Cells(Zeile, Spalte) = DatLfd
    Next DatLfd
    
Err_Kalender:
    Application.ScreenUpdating = True

End Sub

1) In der Variable "SpaltenArray" bedeuten die Nummern die Spaltennummern im Arbeitsblatt für die einzelnen Monate. Dabei ist die erste 0 nur eine Füllzahl, weil die Monate von 1 bis 12 nummeriert sind und nicht von 0 bis 11.
2) Die bedingte Formatierung musst Du natürlich an die neuen Verhältnisse anpassen.
3) Falls Du in der Inputbox auf den Abbrechen-Button klickst, wird die Error-Behandlung aktiv (--> Abbruch des Makros).

 

Hallo Anton,

bin noch auf Arbeit. Aber erst mal recht herzlichen Dank. Sobald ich zu Hause bin werde ich es testen
und gebe Dir dann noch mal Bescheid.

Bis dahin Gruß
sjbz500

 

Hallo Anton,

bin jetzt am Testen. Es ist genau das was ich brauche, aber einen Wunsch hätte ich da noch.
Bekommst Du es hin das der Januar vom nächsten Jahr mit dabei ist?
Ich sehe dass Du von "NeuJahr To Sylvester" rechnest und hoffe das Du nicht wieder alles umschreiben must.

Gruß sjbz500

P.S. Deine Erklärung absolut Top für einen Anfänger

 

Hallo,

Code:

Sub Kalender()
    Dim intFrage As Integer
    Dim SpaltenArray As Variant
    Dim DatLfd As Date, NeuJahr As Date, [COLOR="#FF0000"][B]Januar31[/B][/COLOR] As Date
    Dim Zeile As Long, Spalte As Long
    
    On Error GoTo Err_Kalender
    intFrage = InputBox("Welches Jahr?")
    
    'Array der Spaltennummern für die Monate 1-12 (Jan=2, Feb=4, .., Dez=39, Jan=41)
    SpaltenArray = Array(0, 2, 4, 7, 11, 14, 20, 26, 29, 33, 35, 37, 39[COLOR="#FF00CD"][B], 41[/B][/COLOR])
    
    Application.ScreenUpdating = False
    
    Cells.ClearContents
    
    NeuJahr = DateSerial(intFrage, 1, 1)
    [COLOR="#FF0000"][B]Januar31[/B][/COLOR] = DateSerial(intFrage + 1, 1, [COLOR="#FF00CD"][B]31[/B][/COLOR])
    
    For DatLfd = NeuJahr To [COLOR="#FF0000"][B]Januar31[/B][/COLOR]
      Zeile = Day(DatLfd) * 2 + 8
      Spalte = SpaltenArray(Month(DatLfd) [COLOR="#FF00CD"][B]+ 12 * (Year(DatLfd) - intFrage)[/B][/COLOR])
      Cells(Zeile, Spalte) = DatLfd
    Next DatLfd
    
Err_Kalender:
    Application.ScreenUpdating = True

End Sub

Folgende Änderungen solltest/musst Du durchführen:
1) An den 3 rot gekennzeichneten Stellen solltest Du "Sylvester" durch "Januar31" ersetzen (aus kosmetischen Gründen).
2) An den 3 violett gekennzeichneten Stellen musst Du Änderungen durchführen:
2a) In der Variablen "SpaltenArray" musst Du zB. die Nr. 41 als 13. Monatsspalte (für die Januarspalte des Folgejahres) hinzufügen.
2b) In der Variablen "Januar31" musst Du den Datumswert ändern, indem Du den Wert "1" in "31" änderst und das "- 1" am Ende entfernst
2c) In der Datumsschleife musst Du bei der "Spalte"-Berechnung den zusätzlichen Ausdruck "+ 12 * (Year(DatLfd) - intFrage)" hinzufügen, damit die Spaltennummerierung korrekt berechnet wird.

 

Hallo Anton,

danke kann ich da nur sagen. Wie im Bilderbuch super beschrieben.
Genau das richtige für einen Anfänger.
Hatte auch schon weitergearbeitet. Geht halt nicht so fix, aber Ergebnis bis jetzt siehe unten.
Jetzt will ich die Bedingte Formatierung loswerden und in VBA die Wochenenden farblich darstellen.
Will das Grundgerüst des Kalenders komplett in VBA haben, aber da muß ich noch ein bische Bücher wälzen
und Video schauen.

Einen schönen Abend noch
Gruß sjbz500