Blätter kopieren, Monatswechsel beachten.

[Didi]

Hallo ihr wissenden,

alle Jahre wieder bastel ich an meinen Stundenzetteln.

Dieses Jahr habe ich es eigendlich fast kpl. geschafft alles nach meinen Wünschen zu ändern.

Ein Punkt ist aber noch offen.

Ich bekam im letzen Jahr ein Macro welches mir den 1. Wochenzettel kopiert.

Sub NewTablesByName()
 Dim i As Integer
 For i = 2 To 52
   Sheets("KW1").Copy after:=Sheets(Sheets.Count)
   Sheets(Sheets.Count).Name = "KW" & i
   ActiveSheet.Range("E2").Value = "KW" & i
 
 Next i
End Sub

Wenn ein Monatswechsel in der Woche stattgefunden hat habe ich einfach ein Blatt eingefügt und entsprechend umbenannt.

Alle Blattübergreifenden Formeln wurden dann von Hand geändert.

Dieses Jahr gibt es nichts Blattübergreifendes.

Was muss gemacht werden damit beim Kopieren die letzte Woche des Monats(hier der Wechsel Jan/ Feb.) mit z.B  KW5.1  und die erste im Febuar KW5.2  beim Kopieren erstellt wird.

Viele Grüße

Didi

[schauan]

Hallöchen,

um mal bei Deinem Strickmuster zu bleiben könnte es so funktionieren (ungetestet):

Code:

Sub NewTablesByName()
Dim i As Integer, dMonday As Date
For i = 2 To 52
  Sheets("KW1").Copy after:=Sheets(Sheets.Count)
  'Montag der KW ermitteln
  dMonday = DateSerial(2017, 1, 4) + i * 7 - 7 - (DateSerial(2017, 1, 2) Mod 7)
  ' wenn der Montag und der Sonntag (Montag + 6) den geleichen Monat haben, dann
  If Month(dMonday) = Month(dMonday + 6) Then
    Sheets(Sheets.Count).Name = "KW" & i
    ActiveSheet.Range("E2").Value = "KW" & i
  'Oder wenn es ein anderer Monat ist, zwei Blaetter erzeugen
  Else
    Sheets(Sheets.Count).Name = "KW" & i & ".1"
    ActiveSheet.Range("E2").Value = "KW" & i
    Sheets("KW1").Copy after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "KW" & i & ".2"
    ActiveSheet.Range("E2").Value = "KW" & i
  'Ende  wenn der Montag und der Sonntag (Montag + 6) den geleichen Monat haben, dann
  End If
Next i
End Sub

[Didi]

Vielen Dank für die Arbeit.

Es hat auf anhieb funktioniert.

Didi