Hausnummern zuordnen

Forumthread: Hausnummern zuordnen

18.02.2005 16:52:53

Frank

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

AW: Hausnummern zuordnen

Kurt

Hei Frank,
bei VBA gut, solltest du das aber hinbekommen.
MfG Kurt

AW: Hausnummern zuordnen

Reinhold

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

AW: Hausnummern zuordnen

Reinhold

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

AW: Hausnummern zuordnen

Frank

Danke für die Hilfe,
muss noch ein wenig basteln, da Straße und Haus Nr. in zwei sep. Zellen stehen und in eine zusammengefügt werden müssen...

Beliebteste Forumthreads (12 Monate)

Forumthread: Hausnummern zuordnen

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread