Thema Datum  Von Nutzer Rating
Antwort
Rot mehrere Dateien n. Kriterium(Spalte A) automatisch erstellen
29.11.2023 09:27:59 Martin
Solved
01.12.2023 21:14:20 Ben
NotSolved
04.12.2023 11:37:19 Gast76699
NotSolved

Ansicht des Beitrags:
Von:
Martin
Datum:
29.11.2023 09:27:59
Views:
1075
Rating: Antwort:
 Nein
Thema:
mehrere Dateien n. Kriterium(Spalte A) automatisch erstellen

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


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot mehrere Dateien n. Kriterium(Spalte A) automatisch erstellen
29.11.2023 09:27:59 Martin
Solved
01.12.2023 21:14:20 Ben
NotSolved
04.12.2023 11:37:19 Gast76699
NotSolved