hi all

noch nicht fertig,aber geht schon mal

gruss nighty

starte das makro mit offner mappe so wird er fuer das eingestellte jahr beschrieben

fuer 2009 also im kalender 2009 einstellen und dann das makro starten

2001-2039 sind erlaubt

Sub neuesjahr()
Dim da(4, 12)
Dim tag$(39), tag1$(7)
Dim Dat1(12) As String
da(1, 1) = 31
da(1, 2) = 29
da(1, 3) = 31
da(1, 4) = 30
da(1, 5) = 31
da(1, 6) = 30
da(1, 7) = 31
da(1, 8) = 31
da(1, 9) = 30
da(1, 10) = 31
da(1, 11) = 30
da(1, 12) = 31
da(2, 1) = 31
da(2, 2) = 28
da(2, 3) = 31
da(2, 4) = 30
da(2, 5) = 31
da(2, 6) = 30
da(2, 7) = 31
da(2, 8) = 31
da(2, 9) = 30
da(2, 10) = 31
da(2, 11) = 30
da(2, 12) = 31
da(3, 1) = 31
da(3, 2) = 28
da(3, 3) = 31
da(3, 4) = 30
da(3, 5) = 31
da(3, 6) = 30
da(3, 7) = 31
da(3, 8) = 31
da(3, 9) = 30
da(3, 10) = 31
da(3, 11) = 30
da(3, 12) = 31
da(4, 1) = 31
da(4, 2) = 28
da(4, 3) = 31
da(4, 4) = 30
da(4, 5) = 31
da(4, 6) = 30
da(4, 7) = 31
da(4, 8) = 31
da(4, 9) = 30
da(4, 10) = 31
da(4, 11) = 30
da(4, 12) = 31
Dat1(1) = "Jan "
Dat1(2) = "Feb "
Dat1(3) = "Mär "
Dat1(4) = "Apr "
Dat1(5) = "Mai "
Dat1(6) = "Jun "
Dat1(7) = "Jul "
Dat1(8) = "Aug "
Dat1(9) = "Sep "
Dat1(10) = "Okt "
Dat1(11) = "Nov "
Dat1(12) = "Dez "
tag1$(1) = "Montag"
tag1$(2) = "Dienstag"
tag1$(3) = "Mittwoch"
tag1$(4) = "Donnerstag"
tag1$(5) = "Freitag"
tag1$(6) = "Samstag"
tag1$(7) = "Sonntag"
tag$(1) = "Montag"
tag$(2) = "Dienstag"
tag$(3) = "Mittwoch"
tag$(4) = "Donnerstag"
tag$(5) = "Samstag"
tag$(6) = "Sonntag"
tag$(7) = "Montag"
tag$(8) = "Dienstag"
tag$(9) = "Donnerstag"
tag$(10) = "Freitag"
tag$(11) = "Samstag"
tag$(12) = "Sonntag"
tag$(13) = "Dienstag"
tag$(14) = "Mittwoch"
tag$(15) = "Donnerstag"
tag$(16) = "Freitag"
tag$(17) = "Sonntag"
tag$(18) = "Montag"
tag$(19) = "Dienstag"
tag$(20) = "Mittwoch"
tag$(21) = "Freitag"
tag$(22) = "Samstag"
tag$(23) = "Sonntag"
tag$(24) = "Montag"
tag$(25) = "Mittwoch"
tag$(26) = "Donnerstag"
tag$(27) = "Freitag"
tag$(28) = "Samstag"
tag$(29) = "Montag"
tag$(30) = "Dienstag"
tag$(31) = "Mittwoch"
tag$(32) = "Donnerstag"
tag$(33) = "Samstag"
tag$(34) = "Sonntag"
tag$(35) = "Montag"
tag$(36) = "Dienstag"
tag$(37) = "Donnerstag"
tag$(38) = "Freitag"
tag$(39) = "Samstag"
j2 = Val(Mid$(Date, 7, 4)) - 2000
Do
If j2 < 4 Then
Exit Do
Else
j2 = j2 - 4
j4 = j4 + 4
End If
Loop
tz = 1
j4 = j4 + j2
j2 = j2 + 1
For u = 1 To 7
If tag$(j4) = tag1$(u) Then tz1 = u
Next u
zeile = 3
For t = 1 To 12
If t < 13 Then
Sheets("" & Dat1(t) & Val(Mid$(Date, 7, 4))).Select
If tz1 = 8 Then zeile = zeile - 3
End If
For t1 = 1 To da(j2, t)
If tz1 = 8 Then
tz1 = 1
zeile = zeile + 3
End If
Cells(zeile - 1, tz1) = tag1$(tz1)
Cells(zeile, tz1) = Str(t1) + "." & Str(t) & "." & Val(Mid$(Date, 7, 4))
tz1 = tz1 + 1
Next t1
zeile = 3
Next t
End Sub

hallo nighty
habs so eben geschaft ist sichen nicht so profesionen aber funktionirt tadellos

Danke für deine Bemühnen

Sub Kalender()

Dim jahr As Integer
Dim monat As Integer
Dim tag As Integer
Dim TJan As Date
Dim TFeb As Date
Dim TMar As Date
Dim TApr As Date
Dim TMai As Date
Dim TJun As Date
Dim TJul As Date
Dim TAug As Date
Dim TSep As Date
Dim TOkt As Date
Dim TNov As Date
Dim TDez As Date

Dim TJan1 As Date
Dim TFeb1 As Date
Dim TMar1 As Date
Dim TApr1 As Date
Dim TMai1 As Date
Dim TJun1 As Date
Dim TJul1 As Date
Dim TAug1 As Date
Dim TSep1 As Date
Dim TOkt1 As Date
Dim TNov1 As Date
Dim TDez1 As Date


Dim m ' Maonate Ablaufen für Tabellen
Dim T ' Tage auffülen
Dim s ' start punkt
Dim z 'zeilen
Dim a 'auffüllen Kalender
Dim p ' alle kalender
Dim x ' Löschen der Lehren Felder

Dim datumAktuel
Sheets(1).Select
datumAktuel = Cells(1, "F")
jahr = Cells(1, 1)
sc = 0

Sheets("Hilfstabelle").Select




'If Cells(5, 1) = "Schaltjahr" Then
'sjahrjan = 366
'Else: sjahrjan = 365
'End If
'sJahr = 365

TJan = "31.01." & jahr
If Cells(5, 1) = "Schaltjahr" Then
TFeb = "29.02." & jahr
Else: TFeb = "28.02." & jahr
End If

TMar = "31.03." & jahr
TApr = "30.04." & jahr
TMai = "31.05." & jahr
TJun = "30.06." & jahr
TJul = "31.07." & jahr
TAug = "31.08." & jahr
TSep = "30.09." & jahr
TOkt = "31.10." & jahr
TNov = "30.11." & jahr
TDez = "31.12." & jahr

TJan1 = "31.01." & jahr + 1 ' zweites Jahr
If Cells(5, 2) = "Schaltjahr" Then
TFeb1 = "29.02." & jahr + 1
Else: TFeb1 = "28.02." & jahr + 1
End If

TMar1 = "31.03." & jahr + 1
TApr1 = "30.04." & jahr + 1
TMai1 = "31.05." & jahr + 1
TJun1 = "30.06." & jahr + 1
TJul1 = "31.07." & jahr + 1
TAug1 = "31.08." & jahr + 1
TSep1 = "30.09." & jahr + 1
TOkt1 = "31.10." & jahr + 1
TNov1 = "30.11." & jahr + 1
TDez1 = "31.12." & jahr + 1

Sheets(2).Select

If Weekday(datumAktuel) = 2 Then Cells(3, 1) = datumAktuel: T = 1
If Weekday(datumAktuel) = 3 Then Cells(3, 2) = datumAktuel: T = 2
If Weekday(datumAktuel) = 4 Then Cells(3, 3) = datumAktuel: T = 3
If Weekday(datumAktuel) = 5 Then Cells(3, 4) = datumAktuel: T = 4
If Weekday(datumAktuel) = 6 Then Cells(3, 5) = datumAktuel: T = 5
If Weekday(datumAktuel) = 7 Then Cells(3, 6) = datumAktuel: T = 6
If Weekday(datumAktuel) = 1 Then Cells(3, 7) = datumAktuel: T = 7



p = 7
For a = 3 To 13 Step 2
For d = 1 To p - T



If datumAktuel = TJan Then Sheets(3).Select: a = 3
If datumAktuel = TFeb Then Sheets(4).Select: a = 3
If datumAktuel = TMar Then Sheets(5).Select: a = 3
If datumAktuel = TApr Then Sheets(6).Select: a = 3
If datumAktuel = TMai Then Sheets(7).Select: a = 3
If datumAktuel = TJun Then Sheets(8).Select: a = 3
If datumAktuel = TJul Then Sheets(9).Select: a = 3
If datumAktuel = TAug Then Sheets(10).Select: a = 3
If datumAktuel = TSep Then Sheets(11).Select: a = 3
If datumAktuel = TOkt Then Sheets(12).Select: a = 3
If datumAktuel = TNov Then Sheets(13).Select: a = 3
If datumAktuel = TDez Then Sheets(14).Select: a = 3

If datumAktuel = TJan1 Then Sheets(15).Select: a = 3
If datumAktuel = TFeb1 Then Sheets(16).Select: a = 3
If datumAktuel = TMar1 Then Sheets(17).Select: a = 3
If datumAktuel = TApr1 Then Sheets(18).Select: a = 3
If datumAktuel = TMai1 Then Sheets(19).Select: a = 3
If datumAktuel = TJun1 Then Sheets(20).Select: a = 3
If datumAktuel = TJul1 Then Sheets(21).Select: a = 3
If datumAktuel = TAug1 Then Sheets(22).Select: a = 3
If datumAktuel = TSep1 Then Sheets(23).Select: a = 3
If datumAktuel = TOkt1 Then Sheets(24).Select: a = 3
If datumAktuel = TNov1 Then Sheets(25).Select: a = 3
If datumAktuel = TDez1 Then GoTo Februar:
Cells(a, T + d) = datumAktuel + 1: datumAktuel = datumAktuel + 1

Next d
p = 7
T = 0
Next a
Februar:
For x = 2 To 25
Sheets(x).Select
If Cells(13, 1) = "" Then Rows("13:14").Select: Selection.Delete Shift:=xlUp
If Cells(11, 1) = "" Then Rows("11:12").Select: Selection.Delete Shift:=xlUp
Next x
End Sub