Hausnummern zuordnen

Hallo liebe Leute,
habe eine Riesen-Datei mit tausenden von Straßen und Nr. aufgelistet in sep. Zeilen (beispiel unten). Straßen und Nummern tauchen ungeordnet auf und müssen in nur ZWEI Zellen. Siehe Beispiel 2-te Datei.
Kann mir jemand helfen, mit Formel oder VBA
Danke, Frank B.
STRASSE NR.
Preußenstr. 2
Preußenstr. 4
Klinkeburg 1
Klinkeburg 1
Weg 4
Weg 6
Weg 8
Weg 10
Weg 3
Weg 5
Weg 7
Wilhelm-Krüger-Str. 1
Wilhelm-Krüger-Str. 2
Wilhelm-Krüger-Str. 3
Wilhelm-Krüger-Str. 4
Bremer Str. 2
Bremer Str. 4
Bremer Str. 6
Preußenstr. 6
Preußenstr. 8
Wilhelm-Krüger-Str. 5
Wilhelm-Krüger-Str. 6
Wilhelm-Krüger-Str. 7
So muss das Ergebnis aussehen:
STRASSE NUMMERN
Preußenstr. 2,4,6,8
Klinkeburg 1
Weg 3,4,5,6,7,8,10
Wilhelm-Krüger-Str. 1,2,3,4,5,6,7
Bremer Str. 2,4,6

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Frank,
hab' dir ein kleine Macro geschrieben!
Die Hausnummern werden sortiert ausgegeben.
Ich hoffe es hilft dir weiter!


Sub sMain()
Dim r As Range
Dim coll As Collection
Dim arr() ' speichert die Hausnummern einer Strasse
Dim Strasse As String, HausNr As Long
Dim EingabeBereich As Range ' Zellen, die analisiert werden
Dim BeginnAusgabeZeile
Dim ExistsHNr As Boolean ' true, falls HausNr in dieser Strasse bereits vorhanden
Dim v As Variant, i As Long, j As Long, lng As Long
Set coll = New Collection
Set EingabeBereich = Range("A1").CurrentRegion
' Adressen in Collection speichern, damit doppelte Adressen erkannt werden können
' die Hausnummern je Adresse in array speichern
For Each r In EingabeBereich.Cells
Strasse = Left(r.Value, InStrRev(r.Value, " ") - 1)
HausNr = Mid(r.Value, InStrRev(r.Value, " ") + 1)
On Error Resume Next
arr = coll(Strasse)
If Err = 0 Then ' Strasse kommt bereits vor
On Error GoTo 0
' Überprüfen ob Hausnummer bereits vorkomme
ExistsHNr = False
For i = 1 To UBound(arr)
If arr(i) = HausNr Then
ExistsHNr = True
Exit For
End If
Next i
' Hausnummer hinzufügen, falls diese HausNr das erste mal vorkomme
If Not ExistsHNr Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = HausNr
coll.Remove Strasse
coll.Add key:=Strasse, Item:=arr
End If
Else ' Strasse kommt das erste mal vor
On Error GoTo 0
ReDim arr(1)
arr(0) = Strasse
arr(1) = HausNr
coll.Add key:=Strasse, Item:=arr
End If
Next r
' Ausgabe
BeginnAusgabeZeile = EingabeBereich.Cells(EingabeBereich.Cells.Count).Row + 2
For Each v In coll
' v sortieren
For i = 1 To UBound(v)
For j = i To UBound(v)
If v(i) > v(j) Then
lng = v(i)
v(i) = v(j)
v(j) = lng
End If
Next j
Next i
Cells(BeginnAusgabeZeile, EingabeBereich.Column).Value = Join(v, ", ")
BeginnAusgabeZeile = BeginnAusgabeZeile + 1
Next v
End Sub

grüße Reinhold

Sub sMain() Dim r As Range Dim coll As Collection Dim arr() ' speichert die Hausnummern einer Strasse Dim Strasse As String, HausNr As Long Dim EingabeBereich As Range ' Zellen, die analisiert werden Dim BeginnAusgabeZeile Dim ExistsHNr As Boolean ' true, falls HausNr in dieser Strasse bereits vorhanden Dim v As Variant, i As Long, j As Long, lng As Long Set coll = New Collection Set EingabeBereich = Range("A1").CurrentRegion ' Adressen in Collection speichern, damit doppelte Adressen erkannt werden können ' die Hausnummern je Adresse in array speichern For Each r In EingabeBereich.Cells Strasse = Left(r.Value, InStrRev(r.Value, " ") - 1) HausNr = Mid(r.Value, InStrRev(r.Value, " ") + 1) On Error Resume Next arr = coll(Strasse) If Err = 0 Then ' Strasse kommt bereits vor On Error GoTo 0 ' Überprüfen ob Hausnummer bereits vorkomme ExistsHNr = False For i = 1 To UBound(arr) If arr(i) = HausNr Then ExistsHNr = True Exit For End If Next i ' Hausnummer hinzufügen, falls diese HausNr das erste mal vorkomme If Not ExistsHNr Then ReDim Preserve arr(UBound(arr) + 1) arr(UBound(arr)) = HausNr coll.Remove Strasse coll.Add key:=Strasse, Item:=arr End If Else ' Strasse kommt das erste mal vor On Error GoTo 0 ReDim arr(1) arr(0) = Strasse arr(1) = HausNr coll.Add key:=Strasse, Item:=arr End If Next r ' Ausgabe BeginnAusgabeZeile = EingabeBereich.Cells(EingabeBereich.Cells.Count).Row + 2 For Each v In coll ' v sortieren For i = 1 To UBound(v) For j = i To UBound(v) If v(i) > v(j) Then lng = v(i) v(i) = v(j) v(j) = lng End If Next j Next i Cells(BeginnAusgabeZeile, EingabeBereich.Column).Value = Join(v, ", ") BeginnAusgabeZeile = BeginnAusgabeZeile + 1 Next v End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread