Guten Morgen zusammen,
im Jahr 2019 habt ihr mir sehr mit dem folgenden VBA geholfen. Der Code generiert, pro Kriterium in Spalte A, neue einzelne Dateien. Zudem werden alle Formate/Formeln/ausgeblendete Spalten/Blattschutz etc. ebenfalls anhand der "Masterdatei" übernommen. Das funktioniert alles bestens, vielen Dank nochmal an dieser Stelle für die damalige Hilfe.
Private Sub Variante12sek()
Application.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten
Dim Li, wksq, z, ky, lie, s, ze, lastRow
Dim ti 'Nur für Testzwecke
Set Li = CreateObject("Scripting.Dictionary")
Set wksq = ThisWorkbook.ActiveSheet
ti = Timer 'Nur für Testzwecke
With wksq
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For z = 3 To lastRow
lie = UCase(.Cells(z, 1).Text)
If Not Li.Exists(lie) And lie <> "" Then Li.Add lie, lie
Next z
For Each ky In Li.keys
Set wb = Workbooks.Add
.Rows("1:2").Copy wb.Sheets(1).Cells(1, 1)
ze = 3
For z = 3 To lastRow
lie = UCase(.Cells(z, 1).Text)
If lie = ky Then
.Rows(z).Copy wb.Sheets(1).Cells(ze, 1)
ze = ze + 1
End If
Next z
For s = 1 To 43
wb.Sheets(1).Columns(s).Hidden = .Columns(s).Hidden
wb.Sheets(1).Columns(s).ColumnWidth = Columns(s).ColumnWidth
Next s
Rows("2:2").Select
Selection.AutoFilter
wb.Sheets(1).Protect Password:="mdm", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
:=True, AllowInsertingHyperlinks:=True, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Application.DisplayAlerts = False 'Speichern ohne Rückfrage, ob Überschreiben
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ky & ".xlsx", FileFormat:=51
Application.DisplayAlerts = True
wb.Close False
Next
End With
Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
Application.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
MsgBox Timer - ti & " sec." 'Nur für Testzwecke
End Sub
Jetzt ist es so, dass sich die Anforderungen der Datei erweitert haben. Es müssen jetzt z.B. die folgenden Kriterien mit in die neuen Dateien übernommen werden.
- Bedingte Formatierungen
- viele Zellen enthalten Datenüberprüfungen (Wertelisten) die sich auf andere Tabellenblätter innerhalb der Datei beziehen
- die 2 weiteren Tabellenblätter aus der Datei übernehmen
Könnt ihr mir bitte helfen, dass sich die eben aufgezählten Kriterien mit in die neu generierten Dateien übernehmen?
Vielen Dank vorab und beste Grüße
Martin
|