Datei nach Kriterien auf Dateien splitte

Tom · 2022-12-28T15:53:09+00:00

Hallo zusammen, um bei meinem immer noch existierenden Problem weiterzukommen bin ich auf die userformgestützte Lösung von Franz https://www.herber.de/forum/archiv/1324to1328/1325041_ExcelDatei_nach_Kriterien_auf_Dateien_aufspitten.html#1325100 gestossen, die bei mir grds. passen würde. Weiß jemand. wie das Makro anzupassen wäre, wenn nach 2 Kriterien gesplittet würde, z. B. zusätzlich zu Spalte D noch Spalte E? Viele Grüße Tom

Hallo zusammen,
ich habe hier im Forum ein weiteres Makro gefunden, was nun fast die gewünschten Ergebnisse liefert. Hier meine Beispieldatei https://www.herber.de/bbs/user/156995.xlsm. Bei folgendem bin ich bisher nicht weiter gekommen, vielleicht weiß jemand, wie das Makro anzupassen wäre:
- Das letzte 4. Arbeitsblatt "Sonst. 2022" habe ich eingefügt, es werden aber nur 3 getrennt
- Die Kriteriumsspalte sollte A statt D sein
Viele Grüße Tom
Das Makro sieht so aus:
Option Explicit


Sub Trennen()
Dim aktSplitKrit As String
Dim anfZeile As Long
Dim datName As String
Dim endZeile As Long
Dim i As Long
Dim letzteZeile As Long
Dim pfad As String
Dim sinw As Long
Dim sortBereich As Range
Dim wb As Workbook     ' Neu erzeugte Mappe
Dim wbM As Workbook    ' Master
Dim ws As Worksheet
Dim wsFX As Worksheet  ' Blatt "FX" vom Master
Dim wsM As Worksheet   ' Blatt vom Master
Dim zeile As Long
'  Application.ScreenUpdating = False
sinw = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3
Set wbM = ThisWorkbook
pfad = wbM.Path & "\"
Set wsFX = wbM.Worksheets("Beschäft. 2021")
letzteZeile = wsFX.Cells(wsFX.Rows.Count, "A").End(xlUp).Row
If letzteZeile  aktSplitKrit Then
' Wechsel des SplitKriteriumn
endZeile = zeile - 1
Set wb = Workbooks.Add
For i = 1 To 3
Set ws = wb.Worksheets(i)
Set wsM = wbM.Worksheets(i)
ws.Name = wsM.Name
wsM.Rows("1:3").Copy Destination:=ws.Rows("1:3")
wsM.Range(wsM.Rows(anfZeile), _
wsM.Rows(endZeile)).Copy Destination:=ws.Range("A4")
ws.Columns.AutoFit
Next i
datName = aktSplitKrit & ".xlsx"
Application.StatusBar = datName
On Error Resume Next
Workbooks(datName).Close SaveChanges:=False
On Error GoTo 0
Application.DisplayAlerts = False
wb.SaveAs Filename:=pfad & datName
Application.DisplayAlerts = True
wb.Close
anfZeile = endZeile + 1
If Not IsEmpty(wsFX.Cells(anfZeile, "D")) Then
aktSplitKrit = wsFX.Cells(anfZeile, "D")
Else
Exit For
End If
End If
Next zeile
Application.SheetsInNewWorkbook = sinw
Application.ScreenUpdating = True
Application.StatusBar = Empty
End Sub

Hallo Tom,
der einzige vernüftige Grund, warum man Daten teilen sollte, ist, wenn die Empfänger die anderen Daten nicht sehen dürfen. Es scheint bei Dir der Fall zu sein. Ansonsten ist es immer vernünftiger, alle Daten zusammenzuhalten und durch Filter an die gewünschten Daten zu kommen. In deinem Fall wäre es zum Beispiel besser alle Daten auf einem Blatt anstatt auf 4, weil diese genau dieselbe Struktur haben.
Filter: die von Dir verlinkte Lösung macht tatsächlich nur einen Filter auf die Daten, die "den Empfänger nicht sehen dürfte". Was eigentlich ziemlich kurzsichtig ist, weil jeder diesen Filter umstellen kann und somit alle Daten sehen kann. Falls es so gewünscht wäre, würde ich in der originale Datei einen Filter einrichten, aber die Filterung den Empfänger überlassen. Der Aufwand einer Makro (die man in aller Ewigkeit aufrecht und aktuell alten muss) ist damit nicht zu rechtfertigen.
Ich kann auch im Code deines Fundus (dein erstes Posting) nicht erkennen, dass es auf irgendeine Art und Weise Dir näher zu einer Lösung bringt.
Im Prinzip würde die Lösung so aussehen:
_ Liste der eindeutige "Kriterien" über alle Blätter aufsammeln
_ pro gesammelte Eintrag eine Kopie der orignalen Excel mit entsprechenden Namen speichern
_ in dieser Kopie alle Einträge löschen, die den Kriterien nicht erfüllen
es sieht dann so aus: (wo die Kriterien zuerst gelesen und dann geprüft werden, wirst Du selber erkennen können)


Sub Kopie_pro_Kriterien_speichern()
Dim Kriterien_Liste As Object
Dim wbKopie As Workbook
Dim ws As Worksheet
Dim Dateiname As String
Dim R As Long ' R wie Row
Dim Krit ' Krit wie Eintrag
Set Kriterien_Liste = CreateObject("Scripting.Dictionary")
'Liste der eindeutige Einträge sammeln
For Each ws In ThisWorkbook.Sheets
For R = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
Kriterien_Liste(ws.Cells(R, "A").Value & "_" & ws.Cells(R, "D").Value) = 1
Next
Next
'für jede Eintrag der Liste
For Each Krit In Kriterien_Liste.Keys
'eine Kopie der Datei erzeugen
Dateiname = Replace(ThisWorkbook.FullName, ".xlsx", "_" & Krit & ".xlsx")
ThisWorkbook.SaveCopyAs Dateiname
Set wbKopie = Workbooks.Open(Dateiname) 'Kopie öffnen
For Each ws In wbKopie.Worksheets
For R = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1  'beim Löschen immer von unten nach oben
If ws.Cells(R, "A").Value & "_" & ws.Cells(R, "D").Value  Krit Then ws.Rows(R).Delete 'nicht passenden Eintrage löschen
Next
Next
wbKopie.Save
wbKopie.Close
Next
Set Kriterien_Liste = Nothing
End Sub

(ungetestet. Löschen findet nur auf die Kopie statt)
Dein Zwischenpost (11:30): Dieses Coding scheint sehr an einem momentane Zustand deines Bedarf gebunden: funktioniert heute, aber morgen sind es 5 Blätter=Problem.
Wenn Du den Code liest und diese in deutsche Sprache spricht (laut ist sogar besser, weil man sich selbst zuhören muss), dann kannst Du schon evaluieren, ob ein Coding passt oder nicht.
Wenn Du VBA ansetzst, kommst Du nicht darum, Dich damit zu beschäftigen. Willkommen im Club der Programmierer.
VG
Yal

Datei nach Kriterien auf Dateien splitte

Forumthread: Datei nach Kriterien auf Dateien splitte

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Datei nach Kriterien auf Dateien splitte

Forumthread: Datei nach Kriterien auf Dateien splitte

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread