Tabellenblatt speichern als Schleife
23.11.2021 14:26:30
Christian
bisher war ich stiller Teilhaber und Bewunderer eures Wissens und ich konnte mir auch viele Tipps abschauen.
Nun stehe ich allerdings vor einer Aufgabe, die ich alleine nicht bewältigen kann und auch über die Foren-Suche oder Dr. Google nicht zur Zufriedenstellung beantwortet bekommen habe.
Ich habe eine Datei mit über 40 Tabellenblättern. Diese habe ich für meine Frau erstellt und beinhaltet eine Aufschlüsselung des angestellten Personals (Urlaubsplan, Stundenzettel etc.)
Diese Datei ist nur für interne Zwecke und zur Auswertung.
Nun zu meinem Problem. Ich habe ein funktionierendes Makro, welches nach einem bestimmten Ordner sucht und diesen bei nicht Vorhandensein erstellt. Darin werden dann die einzelnen Stundenzettel der Mitarbeiter als Blanko-Datei erstellt (jedes Tabellenblatt als einzelne Datei). Dieses Makro funktioniert auch einwandfrei. Allerdings ist es ziemlich mühsam jeden einzelnen Mitarbeiter einzeln auszuwählen und zu speichern, da ich die Register ausgeblendet haben und nur mit Buttons in der Datei arbeite bzw. meine Frau damit arbeitet. Die Mitarbeiter-Tabellenblätter beginnen immer mit "MB".
Ich würde nun gerne erstens prüfen lassen ob im Blattnamen am Anfang "MB" steht und dann ob in "D5" etwas drin steht. "D5" habe ich als Name deklariert.
Sind beide Parameter erfüllt, soll mein Makro Tabellenblatt speichern und mit dem nächsten Tabellenblatt weiter machen.
Ich hoffe dies ist so umsetzbar?!
Mein Makro sieht, wie folgt aus:
Sub Speichern_MB()
Dim wks As Worksheet
Dim strDname As String
Dim Fso, Ordnername
Dim Monat As String
Dim jzahl As String
Dim Name As String
Dim ordner As String
jzahl = [G7]
Monat = [D7]
Name = [D5]
ordner = "Stundenzettel"
Application.ScreenUpdating = False
'Bildschirmaktualisierung abgeschaltet
Application.DisplayAlerts = False
'Prüfen ob Ordner verhanden, wenn nicht dann anlegen
Set Fso = CreateObject("Scripting.FileSystemObject")
Ordnername = "C:\" & ordner & "\"
If Not Fso.FolderExists(Ordnername) Then
MkDir "C:\" & ordner & "\"
End If
'Prüfen ob Ordner verhanden, wenn nicht dann anlegen
Set Fso = CreateObject("Scripting.FileSystemObject")
Ordnername = "C:\" & ordner & "\" & jzahl & "\"
If Not Fso.FolderExists(Ordnername) Then
MkDir "C:\" & ordner & "\" & jzahl & "\"
End If
'Prüfen ob Ordner verhanden, wenn nicht dann anlegen
Set Fso = CreateObject("Scripting.FileSystemObject")
Ordnername = "C:\" & ordner & "\" & jzahl & "\" & Monat & "\"
If Not Fso.FolderExists(Ordnername) Then
MkDir "C:\" & ordner & "\" & jzahl & "\" & Monat & "\"
End If
strDname = "C:\" & ordner & "\" & jzahl & "\" & Monat & "\" & Name & ".xlsx"
ActiveSheet.Copy
ActiveSheet.SaveAs strDname, FileFormat:=xlOpenXMLWorkbook
'Datei wird als Kopie gespeichert
ActiveSheet.Unprotect Password:="noerr"
ActiveSheet.Buttons.Delete
Range("K46:M49").Select
Selection.Clear
'Selection.FormulaHidden = True
ActiveSheet.EnableSelection = xlUnlockedCells
ActiveSheet.Protect Password:="noerr"
Application.DisplayAlerts = True
'schaltet Meldungen ein
Application.ScreenUpdating = True
'Bildschirmaktualisierung eingeschaltet
ActiveWindow.Close savechanges:=True
End Sub
https://www.herber.de/bbs/user/149333.xlsm
Ich hoffe ich konnte mich einigermaßen verständlich ausdrücken und ihr könnt mir helfen.
Ich bedanke mich im Voraus für eure Bemühungen.
Mit freundlichen Grüßen
Christian