Aufteilen nach Kriterium in Datenblätter
07.03.2020 06:45:35
Diego
Ich habe nun mehrere Stunden versucht, meine bestehende Liste, bestehend aus Adressen, _ aufzuteilen, sortiert nach Strassennamen in einzelne Tabs. Am nächsten zur gewünschten Lösung, bin ich mit folgendem Makro gekommen, dass ich im Netz gefunden habe:
Sub aufteilen()
Dim Zelle1 As Range
Dim Zelle2 As Range
Dim shZiel As Worksheet
Set Zelle2 = Tabelle1.Cells(1, 1)
Zelle2.CurrentRegion.Sort key1:=Zelle2, order1:=xlAscending, Header:=xlYes
Do
Set Zelle1 = Zelle2.Offset(1, 0)
If Zelle1 = "" Then Exit
Sub
Set Zelle2 = Zelle1.EntireColumn.Find(what:=Zelle1.Value, lookat:=xlWhole, searchdirection:= _
_
_
xlPrevious)
On Error Resume Next
Set shZiel = Sheets(Zelle1.Value)
If Err 0 Then
Set shZiel = Worksheets.Add(after:=Sheets(Sheets.Count))
shZiel.Name = Zelle1.Value
Else
shZiel.Cells.Clear
End If
On Error GoTo 0
Tabelle1.Rows(1).Copy shZiel.Cells(1, 1)
Range(Zelle1, Zelle2).EntireRow.Copy shZiel.Cells(2, 1)
Loop
End Sub
Das erste Problem liegt daran, dass im obigen Code die erste Spalte als Kriterium für die Sortierung verwendet wird. Dies konnte ich mit einer vorgängigen kleinen Umstellung der Tabelle umgehen, wäre aber sicher schöner, wenn ich wüsste welche Variabel im Makro die "Sortierungs"-Spalte bezeichnet.
Wichtiger ist aber, dass ich zusätzlich die Formatierung der Ursprungstabelle beibehalten möchte (Schift, Schriftgrössen, Rahmen, Querformat, Drucken aller Spalten auf einer Seite). Zudem möchte ich einen Header über jeder Tabelle haben, bestehend aus 8 Zeilen (inkl. Tabellenüberschrift=Spaltenbezeichnung), einer kleinen Formel in Zelle (B6), sowie einer Grafik oben rechts. Zu guter Letzt möchte ich noch eine kleine Legende in der Fusszeile jeder Tabelle haben.
Die Daten der Ursprungstabelle ändern sich immer wieder, so dass ein Makro m.E. die einzige sinnvolle Lösung darstellt.
Hoffe es kann mir jemand weiterhelfen.
LG
