Neues Blatt nach aktueller KW ?? HILFE !!!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Jürgen,
versuchs mal mit folgenden Code.
Außer "Vorlage" muss kein Blatt in der Mappe enthalten sein. Im Blatt "Vorlage" sollte C3 als Text formatiert sein.
Alle gewünschten Wochen-Blätter werden, wenn sie fehlen, angelegt.
(Das "Public" vor der Fkt. gehört vor "Functi...", also "Public Functio...". Die Funktion ist übrigens auch in Excelformeln nutzbar (z. B. A2=KwDIN(A1) , wenn in A1 ein Datum steht.)
Sub Wochenblsetter() Dim strWo(6) As String, ii As Integer Dim sollWeg As Boolean, istDa As Boolean, ws As Worksheet ' sechs Soll-Wochen ermitteln For ii = 0 To 5 strWo(ii) = Format(KwDIN(Date + 7 * ii), "00") Next ii ' Vorlage als 7. Soll-Woche strWo(6) = "Vorlage" ' prüfen, überflüssige Wochen vorhanden For Each ws In ThisWorkbook.Worksheets sollWeg = True For ii = 0 To 6 If ws.Name = strWo(ii) Then sollWeg = False: Exit For Next ii If sollWeg Then MsgBox "Bitte Woche " & ws.Name & " ausdrucken und löschen." ws.Select Exit Sub End If Next ws ' prüfen, ob sechs Soll-Wochen vorhanden For ii = 0 To 5 istDa = False For Each ws In ThisWorkbook.Worksheets If ws.Name = strWo(ii) Then istDa = True: Exit For Next ws If Not istDa Then If ii = 0 Then Worksheets("Vorlage").Copy Before:=Sheets(1) Else Worksheets("Vorlage").Copy After:=Sheets(ii) End If ActiveSheet.Name = strWo(ii) Cells(3, 3) = strWo(ii) End If Next ii Sheets(1).Select End Sub
Public Function KwDIN%(DD As Date) ' DIN-Kalenderwoche aus Datum Dim tt% tt = (DD - 2) Mod 7 KwDIN = (DD - DateSerial(Year(DD + 3 - tt), 1, tt - 9)) \ 7 End Function Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

KW:

Früh

Dienst vom:

17.10.05

bis

23.10.05

17. Okt.

18. Okt.

19. Okt.

20. Okt.

21. Okt.

22. Okt.

23. Okt.

Bemerkungen

Stärke gesamt

Hallo Jürgen,
schau mal, ob die Planung jetzt schon eine Zukunft hat:


Sub Wochenblaetter()
Dim strWo(7) As String, ii As Integer, zz As Long
Dim sollWeg As Boolean, istDa As Boolean, ws As Worksheet
'                                     sechs Soll-Wochen ermitteln
For ii = 0 To 5
strWo(ii) = Format(KwDIN(Date + 7 * ii), "00")
Next ii
strWo(6) = "Vorlage"   ' Vorlage als 7. Soll-Woche
strWo(7) = "Zukunft"   ' Zukunft als 8. Soll-Woche (evtl.)
'                                  prüfen, ob überflüssige Wochen vorhanden
For Each ws In ThisWorkbook.Worksheets
sollWeg = True
For ii = 0 To 7
If ws.Name = strWo(ii) Then sollWeg = False: Exit For
Next ii
If sollWeg Then
MsgBox "Bitte Woche " & ws.Name & " ausdrucken und löschen."
ws.Select
Exit Sub
End If
Next ws
'                                     prüfen, ob sechs Soll-Wochen vorhanden
For ii = 0 To 5
istDa = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = strWo(ii) Then istDa = True: Exit For
Next ws
If Not istDa Then
If ii = 0 Then
Worksheets("Vorlage").Copy Before:=Sheets(1)
Else
Worksheets("Vorlage").Copy After:=Sheets(ii)
End If
ActiveSheet.Name = strWo(ii)
Cells(3, 3) = strWo(ii)
End If
Next ii
'                 Hinweis auf Blatt "Zukunft", falls vorhanden,
'                 und ein Datum nicht zu weit in der Zukunft liegt
istDa = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = strWo(7) Then istDa = True: Exit For
Next ws
If istDa Then
With Worksheets(strWo(7))
istDa = False
For ii = 3 To 4
For zz = 3 To .Cells(Rows.Count, ii).End(xlUp).Row
If Not IsEmpty(.Cells(zz, ii)) Then
If IsDate(.Cells(zz, ii)) Then
If .Cells(zz, ii) <= Sheets(strWo(5)).Range("O8") Then
Worksheets(strWo(7)).Select
Cells(zz, ii).Select
istDa = True
MsgBox "Bitte Daten von 'Zukunft' übertragen."
Exit For
End If
End If
End If
Next zz
If istDa Then Exit For
Next ii
End With
End If
If Not istDa Then Sheets(1).Select
End Sub

Geändert habe ich auch etwas im


Private Sub Workbook_Open()
' autoopen Makro
' Makro am 23.10.2005 von Juergen aufgezeichnet
'    Application.Run "vorplanung.xls!Wochenblaetter"
Call Wochenblaetter
End Sub

Dann darf sich auch mal der Name der Mappe ändern - und es läuft trotzdem noch.
Mich hat die Größe der Mappe sehr gewundert (870 kB bei den paar Daten) und mal viele ungenutzte Zellen gelöscht. Mit zwei Blättern hat die Datei jetzt 58 kB, mit allen 7 Blättern 152 kB. So lässt sich die Datei dann auch hier hochladen:
https://www.herber.de/bbs/user/27822.xls
Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

Neues Blatt nach aktueller KW ?? HILFE !!!

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread