527 Aufrufe
Gefragt in Tabellenkalkulation von paul288 Einsteiger_in (90 Punkte)

Hallo zusammen,

ich habe eine recht große Datei auf der sich Kostenstellen und Summen befinden. 

Das File müsste zum Schluss so aussehen wie das angefügte Dok (2020-02-27 - BUDGET - CC001 (DRAFT)). 

Es sollte sozusagen alle Kostenstellen ablaufen, und jede einzelne auf dem Desktop in einem Ordner (Pfad) im o.g. Format abspeichern. Darin sind drei verschiedene Ansichten (Tabelle oben, Gesamtsummen mit weiteren Werten unten und im Tabellenblatt DBASE eine weitere.

Wenn wie im Draft-File (2020-02-27 - BUDGET - DRAFT) sich 4 Kostenstellen befinden (001,002,0021,0042), sollten 4 Dateien entstehen, jede der drei Ansichten sollte nur die jeweilige Kostenstellen beinhaltet.... Das File würde dann wie oben schon geschrieben 2020-02-27 - BUDGET - CC001 heißen und aussehen...

Ich verzweifle gerade daran jede Stelle einzeln zu kopieren und mache immer wieder Fehler :(

Alleine heute sitze ich schon seit 8 Stunden dran...

Lieben und besten Dank im Voraus

Hauptfile: https://supportnet.de/forum/?qa=blob&qa_blobid=16035887078653974761

Beispielergebnis: https://supportnet.de/forum/?qa=blob&qa_blobid=3046068855484059084

3 Antworten

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

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.

0 Punkte
Beantwortet von paul288 Einsteiger_in (90 Punkte)

Hallo M.O.,

entschuldige das ich mich erst heute melde. Ich lag mit einer Erkältung die letzten Tage flach.

Erst einmal: Man ist das geiiiiiiiiiil laughyes - wusste gar nicht das so etwas möglich ist. Die Aufteilung läuft super schnell. Wie soll ich dir bloß Danken?

Ich schäme mich das ehrlich zu schreiben aber nachdem du gefragt hast...blush

Ist es möglich zwischen der Tabelle und der unteren Ansicht eine Leerzeile einzufügen?

Ich habe ein Bild angefügt.

https://supportnet.de/forum/?qa=blob&qa_blobid=6729674287278858249

Vielen lieben Dank für Deine Mühen blush

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

Hallo Paul,

gern geschehen. Auch das mit der Leerzeile ist kein Problem.

Ändere die Zeile

'nun von unten nach oben alle Zeilen durchlaufen
      For lngZeile = lngLetzteD To lngLetzteA + 2 Step -1

in

'nun von unten nach oben alle Zeilen durchlaufen
 For lngZeile = lngLetzteD To lngLetzteA + 3 Step -1

Gruß

M.O.

 

...