Blatt in HTML exportieren erst ab 16. Tag eines Monats
07.03.2024 16:00:45
Unwissender
für den Folgemonat, also 04_24 gibt es ebenfalls schon ein Blatt für die Vorplanung.
das Ganze wird beim Speichern als HTML exportiert um das auf einem Display anzeigen zu können. Das Makro dazu erstellt eine neue temporäre Mappe und kopiert sich bestimmte Bereiche der Mappe in die neue Temporäre Mappe mit einer bestimmten Formatierung - funktioniert auch alles wunderbar.
Nur wie bekomme ich das jetzt hin, dass er mir den Folgemonat, also den 04_24 jetzt z.B. erst am 16. Tag des aktuellen Monats mit exportiert?
das ist der Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUi As Boolean, Cancel As Boolean)
' Kopie des Dienstplans zur Anzeige
Druckbereich_Speichern
End Sub
Sub Druckbereich_Speichern()
Dim wb As Workbook, ws As Worksheet, NewName As String, rBereich As String, WsName As String
Dim nb As Workbook
Dim fDisplayAlerts As Boolean
fDisplayAlerts = Application.DisplayAlerts ' akt. Einstellung zu Meldungen merken und unten ...
Application.DisplayAlerts = False
Set wb = ActiveWorkbook
WsName = ActiveSheet.Name
NewName = "C:\Temp\DienstPlan.html" ' so heißt die Datei zur Anzeige des Dienstplans auf Display
Set nb = Application.Workbooks.Add ' damit wird die neue (leere) Excel-Datei erzeugt und auch aktiv
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
' gehe über alle Arbeitsblätter (Worksheets/TabSheets).
' Wenn der Name des Arbeitsblattes in der Liste steht (s.u.), dann wird es kopiert in die neue Arbeitsmappe.
If InCopyList(ws.Name) Then ' Wenn in der Liste der zu kopierenden Worksheets enthalten
'ws.Activate
rBereich = ws.PageSetup.PrintArea ' ActiveSheet.PageSetup.PrintArea
If rBereich > "" Then ' kopiere nur den eingestellten Druckbereich
ws.Range(rBereich).Copy
nb.Activate
nb.ActiveSheet.Name = ws.Name
Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats 'Werte und Zellformate einfügen
Range("A1").PasteSpecial Paste:=xlPasteFormats 'Formatierungen einfügen
Range("A1").PasteSpecial Paste:=xlPasteColumnWidths 'Spaltenbreiten einfügen
Range("A1").Select 'Select um Bereichsmarkierung aufzuheben
Application.CutCopyMode = False
Else
Range("A1").Value = "Kein Druckbereich festgelegt."
End If
nb.Worksheets.Add After:=nb.Worksheets(nb.Worksheets.Count) ' ein neues TabSheet anfügen für den nächsten Durchlauf
End If
Next
'nb.Worksheets(WsName).Activate
nb.Worksheets(1).Activate ' damit steht der Dienstplan immer auf dem aktuellen Monat
' Am Ende der Schleife füge pauschal ein Tabellen-Blatt ein. Das letzte (nicht benötigte) wird rausgeschmissen
For Each ws In nb.Worksheets
If Not InCopyList(ws.Name) Then
nb.Worksheets(ws.Name).Delete
End If
Next
' Speichern im html-Format (macht sich besser mit dem SiteKiosk)
'ActiveWorkbook.SaveAs Filename:=wb.Path & "\" & NewName & ".html", FileFormat:=xlHtml
ActiveWorkbook.SaveAs NewName, FileFormat:=xlHtml
ActiveWorkbook.Close
wb.Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = fDisplayAlerts ' ... wiederherstellen
End Sub
Function InCopyList(strIn As String) As Boolean
Dim TabSheetList(4) As String
TabSheetList(0) = Format(Now(), "mm_yy")
TabSheetList(1) = Format(DateAdd("m", 1, Now()), "mm_yy") ---- der hier sorgt dafür, dass der Folgemonat mit angezeigt wird
TabSheetList(3) = Format("Plankürzel")
TabSheetList(4) = Format("Jahresurlaub")
TabSheetList(5) = Format("Feiertage") 'wird gebraucht um Feiertage auch in der neuen Temporären Arbeitsmappe mittels sverweis anzuzeigen
InCopyList = Not (IsError(Application.Match(strIn, TabSheetList, 0)))
End Function