AW: Exceldatei generieren incl Makro
16.01.2017 20:59:53
littletramp
Hallo Jan
Ich habe dir eine Demo erstellt (https://www.herber.de/bbs/user/110615.xlsm).
Aller Code muss sich in der Originalmappe (die Mappe, die dann die neue Mappe erzeugt) befinden.
Von dieser Mappe wird eine temporäre Kopie gespeichert. Dann wird die Kopie gleich geöffnet, ev. nichtbenötigte Blätter entfernt, Tabellen angepasst, und der Anwender aufgefordert die Mappe unter neuem Namen abzuspeichern. Zum Schluss wird dann noch die temporäre Kopie gelöscht.
Das Erzeugen der neuen Mappe erfolgt mit Sub NeueMappeMitMakrosErzeugen() die sich im Tabellenblatt "Erzeuge neue Mappe mit Makro" befindet (siehe auch Schaltfläche auf Tabellenblatt).
Dieses Blatt wird in der neuen Mappe gelöscht, somit ist dieser Code in der neuen Mappe nicht mehr vorhanden.
Falls du noch Code hast, der in der neuen Mappe erhalten bleibt, und der dort nicht ausgeführt werden darf, so kannst du die Ausführung durch hinzufügen nachfolgender Zeile verhindern (als erste Zeile in Public Sub/Function).
If Not IstOriginalmappe Then Exit Sub
Beim wiederholten Öffnen der neu erzeugten Mappe wird dann der für die neu erzeugte Mappe erstellte Code von Workbook_Open() ausgeführt.
Damit es funktioniert muss in der Originalmappe der Name FlagIstOriginalmappe mit dem Wert TRUE enthalten sein. Dieser Name wird dann beim Erzeugen der Neuen Mappe gelöscht. So ist erkennbar, ob es sich um die Originalmappe, oder um eine neu erstellte Mappe handelt.
Das Flag kannst du mit Sub ErzeugeFlagIstOriginalmappe() erzeugen die sich im Sheet("Erzeuge neue Mappe mit Makro") befindet.
Code in Diese Arbeitsmappe:
Option Explicit
Private Sub Workbook_Open()
' Prüfen ob Originalmappe, oder neu erzeugte Mappe
If IstOriginalmappe Then
Sheets("Erzeuge neue Mappe mit Makro").Activate
Else
MsgBox "Workbook_Open von neuer Mappe"
End If
End Sub
Code im Sheet("Erzeuge neue Mappe mit Makro"):
Option Explicit
' Markus Schmid, info@maschmid.ch
Private Sub NeueMappeMitMakrosErzeugen()
Dim wbk As Workbook
Dim obj As Object
Dim wsh As Worksheet
Dim dlg As FileDialog
Dim strTempFileName As String
' Nur Ausführen wenn Originalmappe
If Not IstOriginalmappe Then Exit Sub
strTempFileName = ThisWorkbook.Path & "\Temp_" & Format(Now, "dd_mm_yy_hh_mm_ss") & ".xlsm"
ThisWorkbook.SaveCopyAs strTempFileName
Set wbk = Workbooks.Open(strTempFileName)
For Each obj In wbk.Sheets
Select Case obj.Name
Case "Voreinstellungen", "Feiertage", "Januar", _
"Februar", "März", "April", "Mai", "Juni", _
"Juli", "August", "September", "Oktober", _
"November", "Dezember", "Jahresübersicht", _
"Fahrtkosten", "Berechnungen"
' nichts machen
Case Else
' Sheet löschen
Application.DisplayAlerts = False
obj.Delete
Application.DisplayAlerts = True
End Select
Next
' hier weitere Anpassungen ausführen
For Each wsh In wbk.Worksheets
' Beispielcode
wsh.Range("A1").Value = wsh.Name
wsh.Range("A2").Value = FormatDateTime(Now, vbShortTime)
Next
' Nun Flag entfernen
wbk.Names("FlagIstOriginalmappe").Delete
' Nun vom Anwender unter anderem Namen speichern lassen
Do ' Endlosschleife mit Exit Do
Set dlg = Application.FileDialog(msoFileDialogSaveAs)
dlg.InitialFileName = "" ' hier ev. Name vorgeben
dlg.FilterIndex = 2 ' 2: Excel-Arbeitsmappe mit Makros
dlg.Show
' Wenn anderer Name eingegeben, so Mappe speichern,
' temp. Datei löschen, und Schleife verlassen.
If dlg.SelectedItems(1) strTempFileName Then
dlg.Execute ' Mappe speichern
Kill strTempFileName ' temp. Datei löschen
Exit Do ' Schleife verlassen
Else
MsgBox "Sie müssen die Datei unter" & vbLf _
& "einem neuen Namen speichern!", vbExclamation
End If
Loop
End Sub
Private Sub ErzeugeFlagIstOriginalmappe()
ThisWorkbook.Names.Add "FlagIstOriginalmappe", "=TRUE"
End Sub
Und hier noch der Code zum ermitteln ob es sich um die Originalmappe handelt.
Code in Modul modFlagHandling:
Option Explicit
Option Private Module
Public Function IstOriginalmappe() As Boolean
On Error Resume Next
IstOriginalmappe = ThisWorkbook.Names("FlagIstOriginalmappe").Value = "=TRUE"
On Error GoTo 0
End Function
Ich hoffe, dass du meine Lösung brauchen kannst, hat mich viel Zeit gekostet :-)
Gruss Markus