AW: Werte aus tabelle übernehmen - VBA
04.10.2020 15:57:03
fcs
Hallo Mike,
es wundert mich, dass bei dem Kopiervorgang auch die bedingten Formatierungen verschwunden sind - keine Ahnung warum.
Blattschutz und Gliederungsfunktion sind leider nur bedingt in Einklang zu bringen.
Wenn man beim Blattschutz das Formatieren der Zeilen und Spalten erlaubt, dann sind zumindest die +--Schaltflächen der Gliederung funktionsfähig, aber nicht die nummerierten Schaltflächen für die Ebenen der Gliederung. Dies funktioniert nur, wenn man dies per Makro aktiviert.
Die Einstellung ist flüchtig und wird nicht permanent mit der Datei gespeichert.
Damit die Drop-Downs funktionieren muss auch das Blatt "Config" mit kopiert werden.
Damit alles einigermaßen funktioniert bin ich jetzt wie folgt vorgegangen:
1. Eine temporäre Kopie der Datei wird gespeichert
2. die Kopie wird geöffnet und die nicht benötigten Blätter in der Kopie gelöscht
3. Der Schutz aller Blätter wird ausgeschaltet
4. Die Datei wird als Vorlage ohne Makros gespeichert und geschlossen
5. Jetzt wird die Liste im Blatt "Input Data" abgearbeitet
vor dem Speichern wird der Blattschutz in allen Blättern aktiviert. Dabei wird das Formatieren von Spalten und Zeilen erlaubt.
Die temporär erstellte Kopie und die Vorlage werden wieder gelöscht.
In der Statuszeile wird der Fortschritt der Erstellung der Dateien angezeigt, am Schluss eine kurze Meldung. Bildschirmaktualisierung, Ereignismakros und automatische Berechnung werden vorübergehend deaktiviert, um die Geschwindigkeit des Makros zu erhöhen.
Ich hab dir zusätzlich ein Makro erstellt, mit dem du die Gliederungsfunktion komplett aktiveren kannst. Dieses müsstest du in deiner persönlichen Makroarbeitsmappe speichern.
Nach dem Öffnen einer der erstellten Dateien musst du dann jeweils dieses Makro starten.
LG
Franz
Sub Test()
Dim Qw As Worksheet 'Quelle
Dim Zw As Worksheet 'Ziel
Dim Nw As Workbook 'neue
Dim Z
Dim strOrdnerZiel, strDatum As String, strDateiZiel As String
Dim strTemp As String
Dim StatusCalc As Long, DatNr As Long
strDatum = InputBox("Datum für zu erstellende Dateien", "Vorlagen erstellen", _
Format(Date, "YYYYMMDD"))
If strDatum = "" Then Exit Sub
'Zielordner
strOrdnerZiel = "C:\Users\xxx\Desktop\Bottomup Templates\"
' strOrdnerZiel = "C:\Users\Public\Test\Neuer Ordner\" 'testzeile
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Application.StatusBar = "Temporäre Kopie erstellen"
'temporäre Kopie der Datei speichenr
strTemp = "XXtempKopieXX"
Application.DisplayAlerts = False
ThisWorkbook.SaveCopyAs Filename:=strOrdnerZiel & strTemp & ".xlsm"
'temp. Kopie öffnen
Set Nw = Application.Workbooks.Open(Filename:=strOrdnerZiel & strTemp & ".xlsm")
'nicht benötigte Blätter in Kopie löschen
With Nw
' .Worksheets("config").Delete
.Worksheets("Input data").Delete
'Blattschutz in allen Blättern der aufheben
For Each Zw In Nw.Worksheets
Zw.Unprotect ("VP123")
Next
'Datei ohne Makros speichern
.SaveAs Filename:=strOrdnerZiel & strTemp & ".xlsx", FileFormat:=51
.Close False
End With
'temp. Kopie mit Makros wieder löschen
VBA.Kill strOrdnerZiel & strTemp & ".xlsm"
Application.DisplayAlerts = True
'Basisdateiname
strDateiZiel = strOrdnerZiel & strDatum & "_Market Estimations_RegX_"
Set Qw = ThisWorkbook.Worksheets("Input data")
DatNr = 0
For Each Z In Qw.Range("A2", Qw.Range("A1").End(xlDown)).Cells
DatNr = DatNr + 1
Application.StatusBar = "Datei " & DatNr & " für """ & Z.Offset(0, 1).Value _
& """ wird erstellt"
'temp. Kopie schreibgeschützt öffnen
Set Nw = Application.Workbooks.Open(Filename:=strOrdnerZiel & strTemp & ".xlsx", _
ReadOnly:=True)
Set Zw = Nw.Worksheets("Infrastructure")
Zw.Range("B3") = Z.Offset(0, 3).Value '[Sales Region], spalte 4
Zw.Range("B4") = Z.Offset(0, 2).Value '[Region], Spalte 3
Zw.Range("B5") = Z.Offset(0, 1).Value '[Country], Spalte 2
Zw.Range("C5") = Z.Value '[Country Code], Spalte 1
'Blattschutz aktivieren, dabei Formatierung von Spaltung und Zeilen zulassen, so _
ist die Gliederungsfunktion mit Einschränkungen nutzbar.
For Each Zw In Nw.Worksheets
With Zw
.Protect AllowFormattingColumns:=True, AllowFormattingRows:=True, _
userinterfaceonly:=True, AllowFiltering:=True, Password:="VP123" 'Passwort _
anpassen
.EnableAutoFilter = True 'ermöglicht Autofilter
.EnableOutlining = True 'ermöglicht Gruppierung/Gliederung
End With
Next
Select Case Z.Offset(0, 1).Value
Case "Germany"
Nw.SaveAs _
Filename:=strDateiZiel & Z.Offset(0, 1).Value & "_" & Z.Offset(0, 2).Value _
& ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Case Else
Nw.SaveAs _
Filename:=strDateiZiel & Z.Offset(0, 1).Value & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Select
Nw.Close savechanges:=False
'Exit For - nur zum Testen
Next
'temp. Kopie ohne Makros wieder löschen
VBA.Kill strOrdnerZiel & strTemp & ".xlsx"
'Makrobremsen lösen
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
MsgBox "Fertig"
End Sub
'Dieses Makro in der persönlichen Arbeitsmappe speichern und bei Bedarf starten, _
ggf. einer Schaltfläche in der Menüleiste für den Schnellzugriff zuweisen.
Sub Aktivieren_Gliederung()
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
wks.Unprotect Password:="VP123"
wks.EnableAutoFilter = True
wks.EnableOutlining = True
wks.Protect Password:="VP123", AllowFormattingColumns:=True, AllowFormattingRows:=True, _
userinterfaceonly:=True, AllowFiltering:=True 'Passwort anpassen
Next
End Sub