Bitteschön - schöne Aufgabe muss ich sagen.
Code:
Option Explicit
Sub aufteilen()
Dim letzte As Long, freie As Long
Dim i As Long, j As Long, Anzahl As Long
Dim Ziel As Worksheet
Dim Suche As Range
Dim Suche2 As Integer
Application.ScreenUpdating = False
Set Ziel = Sheets("Ergebnis")
Sheets("Vorlage").Copy after:=Worksheets(Worksheets.Count)
Sheets(Worksheets.Count).Name = "Hilf"
With Worksheets("Hilf")
letzte = .Cells(.Rows.Count, 1).End(xlUp).Row
'Sortieren nach Straße, Bezirk, Hausnummer
.Sort.SortFields.Clear
.Sort.SortFields.Add2 Key:=Range("A1:A" & letzte), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=Range("D1:D" & letzte), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=Range("B1:B" & letzte), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets("Hilf").Sort
.SetRange Range("A1:D" & letzte)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Festlegen, ob Hausnummer gerade oder ungerade
.Range("E1").FormulaLocal = "=WENN(ISTGERADE(B1);B1;"""")"
.Range("F1").FormulaLocal = "=WENN(ISTUNGERADE(B1);B1;"""")"
.Range("E1:F1").Copy
.Range("E1:F" & letzte).PasteSpecial xlPasteFormulas
For i = 1 To letzte
Anzahl = WorksheetFunction.CountIfs(.Columns(1), .Cells(i, 1), .Columns(4), .Cells(i, 4))
freie = Ziel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Ziel.Cells(freie, 1) = .Cells(i, 1)
'Übertrage gerade von
Set Suche = .Range(.Cells(i, 5), .Cells(i + Anzahl - 1, 5)).Find(what:=WorksheetFunction.Min _
(.Range(.Cells(i, 5), .Cells(i + Anzahl - 1, 5))), lookat:=xlWhole, LookIn:=xlValues)
If Not Suche Is Nothing Then
Ziel.Cells(freie, 2) = Suche.Value
Ziel.Cells(freie, 3) = Suche.Offset(, -2).Value
End If
'Übertrage gerade bis
Set Suche = .Range(.Cells(i, 5), .Cells(i + Anzahl - 1, 5)).Find(what:=WorksheetFunction.Max _
(.Range(.Cells(i, 5), .Cells(i + Anzahl - 1, 5))), lookat:=xlWhole, LookIn:=xlValues)
If Not Suche Is Nothing Then
Ziel.Cells(freie, 4) = Suche.Value
Ziel.Cells(freie, 5) = Suche.Offset(, -2).Value
End If
'Übertrage ungerade von
Set Suche = .Range(.Cells(i, 6), .Cells(i + Anzahl - 1, 6)).Find(what:=WorksheetFunction.Min _
(.Range(.Cells(i, 6), .Cells(i + Anzahl - 1, 6))), lookat:=xlWhole, LookIn:=xlValues)
If Not Suche Is Nothing Then
Ziel.Cells(freie, 6) = Suche.Value
Ziel.Cells(freie, 7) = Suche.Offset(, -3).Value
End If
'Übertrage ungerade bis
Set Suche = .Range(.Cells(i, 6), .Cells(i + Anzahl - 1, 6)).Find(what:=WorksheetFunction.Max _
(.Range(.Cells(i, 6), .Cells(i + Anzahl - 1, 6))), lookat:=xlWhole, LookIn:=xlValues)
If Not Suche Is Nothing Then
Ziel.Cells(freie, 8) = Suche.Value
Ziel.Cells(freie, 9) = Suche.Offset(, -3).Value
End If
'Bezirk übertragen
Ziel.Cells(freie, 10) = .Cells(i, 4)
i = i + Anzahl - 1
Next i
End With
Application.DisplayAlerts = False
Sheets("Hilf").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Zur Info: Der Code ist sicher nicht sehr elegant, aber er sollte machen, was du brauchst.
Und deine Beispieldatei strotzt leider im Ergebnis nur so vor Fehlern, siehe schon Hinweis von Elex. Auch der Eintrag "Alfstraße - gerade von: 5" ist falsch. Wenn man also hier um Hilfe bittet, sollte man wenigstens soviel Energie investieren, dass die Helfer nicht noch rätseln müssen.