VBA Aufteilen einer Excel-Liste auf mehrer Dateien
07.06.2018 14:08:13
Claas
ich habe ein funktionierendes Makro um Anhand eines Kriteriums in Spalte A einer Datei mit 5 Spalten diese in mehrere neue Dateien aufteilt.
Es funktioniert auch soweit, allerdings ist es etwas sperrig, hat jemand eine Idee wie man folgende Punkte verbessern kann:
- Wie kann man statt Standardmäßig 5 Spalten bzw. manueller Anpassung mittels weiterer Zeilen in der If-Schleife eine automatische Ermittlung der belegten Spalten im Blatt 'Quelle' umsetzen?
- Kann man auch Formeln oder sogar Formate mitkopieren statt nur der reinen Daten wie derzeit?
- Derzeit muss man immer das Arbeitsblatt Pivot mit dem Makro in die Datei kopieren, den Bezug der Pivottabelle ändern, sie so sortieren dass nichts leeres ob steht. Hat jemand eine Idee wie man die Auswahl des Strings 'Kriterium' nach dem die Liste aufgeteilt und die neuen Dateien benannt werden aus Spalte A idealerweise ohne Hilfspivot einfacher machen kann bzw. ob man zumindest die Erstellung Tabellenblatts mit der Pivottabelle und dessen anschließende Löschung aus der Datei umsetzen kann?
Vielen Dank vorab!
Sub Pivotrefresh()
Worksheets("Pivot").Activate
ActiveSheet.PivotTables("PivotTable8").PivotCache.Refresh
End Sub
Sub Start()
Dim I As Byte, K As Integer, X As Integer, Y As Integer
Dim Kriterium As String, Pfad As String
Dim AW As String
'Dies bitte anpassen => Pfad, wo gespeichert werden soll
Pfad = "C:\Users\C12390\Desktop\VBA Probe\liste teilen"
'Bildschirmaktualisierung abschalten
Application.ScreenUpdating = False
'Datenbasis neu aufstellen
Pivotrefresh
'Zum richtigen Tabellenblatt springen
Worksheets("Quelle").Activate
'Ende der Quelle finden
Worksheets("Quelle").Cells(Rows.Count, 2).End(xlUp).Activate
K = Replace(ActiveCell.Address(False, False), "B", "")
'Beginn in Zeile => Pivottabelle
I = 5
'Loslaufen
Do
'Ersten Eintrag der zu filternden Kriterien
Kriterium = Worksheets("Pivot").Cells(I, 1)
'Für jedes Kriterium ein Tabellenblatt
Worksheets.Add
ActiveSheet.Name = Kriterium
'Zunächst die Überschriften setzen
Worksheets(Kriterium).Cells(1, 1) = Worksheets("Quelle").Cells(1, 1)
Worksheets(Kriterium).Cells(1, 2) = Worksheets("Quelle").Cells(1, 2)
Worksheets(Kriterium).Cells(1, 3) = Worksheets("Quelle").Cells(1, 3)
Worksheets(Kriterium).Cells(1, 4) = Worksheets("Quelle").Cells(1, 4)
Worksheets(Kriterium).Cells(1, 5) = Worksheets("Quelle").Cells(1, 5)
'Zeile in jedem Tabellenblatt wieder auf zwei setzen
Y = 2
'Die Quelle vom Anfang bis Ende durchlaufen
For X = 1 To K
'Sofern Kriterium entspricht, kopieren
If Worksheets("Quelle").Cells(X, 1) = Kriterium Then
Worksheets(Kriterium).Cells(Y, 1) = Worksheets("Quelle").Cells(X, 1)
Worksheets(Kriterium).Cells(Y, 2) = Worksheets("Quelle").Cells(X, 2)
Worksheets(Kriterium).Cells(Y, 3) = Worksheets("Quelle").Cells(X, 3)
Worksheets(Kriterium).Cells(Y, 4) = Worksheets("Quelle").Cells(X, 4)
Worksheets(Kriterium).Cells(Y, 5) = Worksheets("Quelle").Cells(X, 5)
Y = Y + 1
End If
Next X
'Neue Mappe aufmachen und Tabellenblatt verschieben
Sheets(Kriterium).Move
ActiveWorkbook.SaveAs Filename:=Pfad & "\" & Kriterium & ".xls", FileFormat:= _
xlNormal, CreateBackup:=False
'Aktives Tabellenblatt schließen. Änderungen wurden bereits gespeichert!
ActiveWorkbook.Close
'Nächste Runde
I = I + 1
Loop Until Worksheets("Pivot").Cells(I, 1) = "(Leer)"
AW = MsgBox("Der Vorgang wurde abgeschlossen!", vbOKOnly + vbInformation + vbSystemModal, " _
Hinweis")
Application.ScreenUpdating = True
End Sub