Hallo Paul,
das folgende Makro gehört in eine Standardmodul deiner Quellarbeitsmappe:
Sub Trennen()
Dim arrTabellen(1) As String
Dim lngLetzteA As Long
Dim lngLetzteD As Long
Dim lngZeile As Long
Dim strNameneu As String
Dim strKst As String
Dim lngZaehler As Long
Dim i As Long
Dim arrKst() As String
Dim strPfad As String
Dim bExits As Boolean
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Pfad für den Speicherort - Anpassen
strPfad = "C:\Test\"
'prüfen, ob Pfadangabe mit Backslash endet
If Right(strPfad, 1) <> "\" Then
'ansonsten Backslash ergänzen
strPfad = strPfad & "\"
End If
'Anzahl der Kostenstellen feststellen
With ThisWorkbook.Worksheets("OVERVIEW")
'letzte beschriebene Zeile in Spalte A ermitteln
'1 wird abgezogen, weil in letzter Zeile Total steht
lngLetzteA = .Cells(Rows.Count, 1).End(xlUp).Row - 1
'Feld für Kostenstellen redimensionieren
ReDim arrKst(lngLetzteA)
'Spalte A durchlaufen ab Zeile 3
For lngZeile = 3 To lngLetzteA
'Marker für bereits im Array vorhandene Kostenstelle auf falsch setzen
bExists = False
'erste Kostenstelle in Array schreiben
If lngZaehler = 0 Then
arrKst(0) = .Cells(lngZeile, 1).Value
lngZaehler = lngZaehler + 1
End If
'prüfen, ob Kostenstelle bereits in Array enthalten ist
For i = LBound(arrKst) To UBound(arrKst)
If arrKst(i) = .Cells(lngZeile, 1).Value Then
bExists = True 'Marker auf wahr setzen
Exit For 'Schleife verlassen
End If
Next i
If bExists = False Then
'neue Kostenstelle in Array schreiben
arrKst(lngZaehler) = .Cells(lngZeile, 1).Value
lngZaehler = lngZaehler + 1
End If
Next lngZeile
End With
'Feld auf die tatsächliche Größe redimensionieren
ReDim Preserve arrKst(lngZaehler - 1)
'nun die einzelnen Kostenstellen durchlaufen
For i = LBound(arrKst) To UBound(arrKst)
'Namen für Tabelle der Kostenstelle erstellen
strNameneu = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "-")) & " " & arrKst(i)
'Blätter, die kopiert werden sollen in Array schreiben
arrTabellen(0) = "OVERVIEW"
arrTabellen(1) = "DBASE"
'Arbeitsblätter in neue Arbeitsmappe kopieren
ThisWorkbook.Worksheets(arrTabellen).Copy
'neue Arbeitsmappe speichern
With ActiveWorkbook
.SaveAs Filename:=strPfad & strNameneu
'nun Blätter durchlaufen und alle Zeilen löschen, die nicht der Kostenstelle entsprechen
With .Worksheets("OVERVIEW")
'letzte Zeile in Spalte A ermitteln und 1 abziehen, wegen Zeile Total
lngLetzteA = .Cells(Rows.Count, 1).End(xlUp).Row - 1
'letzte Zeile in Spalte D ermitteln
lngLetzteD = .Cells(Rows.Count, 4).End(xlUp).Row
'nun von unten nach oben alle Zeilen durchlaufen
For lngZeile = lngLetzteD To lngLetzteA + 2 Step -1
'falls keine Übereinstimmung mit Kostenstelle, dann Zeile löschen
If .Cells(lngZeile, 4).Value <> arrKst(i) Then .Cells(lngZeile, 4).EntireRow.Delete
Next lngZeile
For lngZeile = lngLetzteA To 3 Step -1
If .Cells(lngZeile, 1).Value <> arrKst(i) Then .Cells(lngZeile, 1).EntireRow.Delete
Next lngZeile
End With
'nun das Arbeitsblatt DBASE entsprechend bearbeiten
With Worksheets("DBASE")
lngLetzteA = .Cells(Rows.Count, 1).End(xlUp).Row
For lngZeile = lngLetzteA To 2 Step -1
If .Cells(lngZeile, 1).Value <> arrKst(i) Then .Cells(lngZeile, 1).EntireRow.Delete
Next lngZeile
End With
'neue Arbeitsmappe schließen und speichern
.Close (True)
End With
Next i
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
'Abschlussmeldung
MsgBox "Die einzelnen Tabellen wurden erstellt.", 64, "Hinweis"
End Sub
Den Pfad musst du natürlich noch auf deine Bedürfnisse anpassen. Schau mal, ob das so funktioniert, wie du dir das vorstellst.
Gruß
M.O.