Mappe speichern

Ich habe mir diese Mappe:
https://www.herber.de/bbs/user/29470.xls
zusammengebastelt natürlich mit Hilfe von hier :) beim öffnen der Mappe "Vorlage" werden die aktuellen Wochen des Monats erstellt und dann kann ich die Tabellen bearbeiten.Worum es mir nun geht ist das speichern der Mappe.
Gibt es eine Möglichkeit die Mappe unter dem Namen der Tabellenblätter abzuspeichern? z.B. 52.-01.Woche das ganze sollte vor dem schließen sein das LW und der Pfad sollte über eine Constante vorgegeben werden,wenn aber die Mappe schon so heißt (nach Wochen) dann soll keine Abfrage beim schließen mehr kommen.Also die Abfrage soll nur kommen wenn die Mappe "Vorlage" heißt.Ich hoffe ich habe mich verständlich ausgedrückt und es kann mir einer helfen und es gibt eine Möglichkeit.
Danke im vorraus
Rene

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim sPath As String, sName As String Dim dat As Date sPath = "c:\arbeitsachen\stunden\" dat = ActiveSheet.Cells(4, 4).Value sPath = sPath + Trim(Str(Year(dat))) + "\" sPath = sPath + Format(dat, "mmmm") + "\" sName = ActiveSheet.Name Application.DisplayAlerts = False If ActiveWorkbook.Name = "vorlage.xls" Then ActiveWorkbook.SaveAs (sPath + sName) Else ActiveWorkbook.Save End If Application.DisplayAlerts = True End Sub

Hallo Rene,
da du die beiden Prozeduren im Workbook_Open aufrufst, wird bei jedem Öffnen der Mappe (ob von Vorlage oder bereits gespeichert) versucht, die Wochenblätter neu anzulegen. Das geht schief, wenn die Blätter schon angelegt sind. Das könntest du so lösen:


Private Sub Workbook_Open()
If Worksheets.Count < 2 Then WochenAnlegen
End Sub

Das Anlegen der Ordner würde ich nur dann aufrufen, wenn auch die Blätter erstellt werden. Das würde ich dann etwa so machen:


Option Explicit
Sub WochenAnlegen()
Dim datStart As Date, datEnd As Date, lKW As Long
Dim strName As String
Application.ScreenUpdating = False
datStart = DateSerial(Year(Date), Month(Date), 1)
datStart = datStart - Weekday(datStart, 2) + 1 ' geht auf den Montag <= datstart
datEnd = DateSerial(Year(Date), Month(Date), 31)
For lKW = datStart + 7 To datEnd Step 7
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(ISOWeek(CDate(lKW)), "00") & ".-Woche"
Sheets("Vorlage").Cells.Copy ActiveSheet.Cells(1, 1)
Next lKW
With Worksheets(1)
.Name = Format(ISOWeek(CDate(datStart)), "00") & ".-Woche"
strName = Left(.Name, 3)
.Select
End With
strName = JahrOrdnerAnlegen(datEnd) & strName _
& "-" & Format(ISOWeek(CDate(lKW - 7)), "00") & ".Woche"
ActiveWorkbook.SaveAs strName
Application.ScreenUpdating = True
End Sub
Private Function ISOWeek(dat As Date) As Integer
With WorksheetFunction
ISOWeek = Fix((dat - .Weekday(dat, 2) - _
DateSerial(Year(dat + 4 - _
.Weekday(dat, 2)), 1, -10)) / 7)
End With
End Function
Function JahrOrdnerAnlegen(datBis As Date) As String
Dim sPath As String
sPath = "D:\Arbeitsachen\Stunden\"
On Error Resume Next
MkDir sPath & Year(datBis)
sPath = sPath & Year(datBis) & "\"
MkDir sPath & Format(datBis, "mmmm")
sPath = sPath & Format(datBis, "mmmm") & "\"
On Error GoTo 0
JahrOrdnerAnlegen = sPath
End Function

Das ".Move" hinter dem Worksheets.Add habe ich weggelassen - ist unnötig.
In der Schleife werden nur Blätter ab der zweiten Woche angelegt. Für die erste Woche kannst du die Vorlage umbenennen und musst dieses Blatt dann auch nicht löschen.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread