|
Hallo,
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:
- Statt Standardmäßig 5 Spalten bzw. manueller Anpassung automatische Ermittlung der belegten Spalten im Blatt 'Quelle' auf Basis Zeile 1 (Also den Überschriften)?
- Kann man auch Formeln und Formate mitkopiert werden statt nur der reinen Daten?
- 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 Kriterienauswahl ohne Hilfspivot einfacher machen kann bzw. ob man zumindest die Erstellung Tabellenblatts mit der Pivots und anschließend wieder das Blatt mit dem Pivot löschen kann?
Der Makro:
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
|