Straßendaten bereinigen VBA

[lycom87]

Hallo Zusammen,
ich habe einen Datensatz (Straßenliste) in der stehen die Straßen in allen Varianten mit Hausnummern.
Beispiele:
10, NEUTURMSTRASSE
12-14 MAXIMILIAN STRASSE
2 DEPT. STORE NEUHAUSER STRASSE 18
ALTE AKADEMIE*NEUHAUSER STRA?E 8-10
AMALIENSTR.24 RGB.
ARNULFSTR. 61-71
AUGUSTENSTR. 3 LADENGESCHAEFT
BAYERSTRASSE 3-5/EINGANG ZWEIGSTR.5
ERZGIESSEREISTR. 24/III
LANDSBERGER STR. 234 C, 1.OG

Hat jemand eine Idee wie ich evtl mit VBA mit den Straßenendungen (Str, Weg, etc....) eiine Textsuche machen kann...?

[Jockel]

Hallo, nur zur Info..: http://www.ms-office-forum.de/forum/show...p?t=335531

[Gast 123]

Hallo,

ich habe die Angewohnheiğt solche Aufgaben immer in einer kopierten Datei zu bearbeiten. Schutz for Datenverlust.

anbei ein kleines Makro mit dem man alle Arten von ;Strassen suchen und sich seitlich in 2 Spalten weiter notieren kann. Diese Spalten müssen natürlich frei sein. Oder den Offset von Offset(0, 2) auf (0, n) erhöhen. Sinn macht es wenn man vorher in Spalte A eine fortlaufende Lauf-Nr einfügt, sich Button zum Sortieren anlegt, und den Datensatz nach Strasse sortiert. Die Lauf-Nr braucht man zum Zurück-Sortieren. Damit findet man all Arten der Strassenangabe. Beim Sortieren blieben die Arten, die man nicht im Mkaro erfasst hat ja übrig. Deshalb sortiere ich gerne zur Kontrolle.

mfg  Gast 123

Code:

Option Explicit      '14.9.2016   Gast 123   für Clever Forum

Const Bereich = "A2:A13"   'deinen Such Bereich angeben

'Modul zum "STRASSE" auflisten

Sub Strassen_ausfiltern()
Dim AC As Object, Label As String
  For Each AC In Range(Bereich)
     Label = Empty   'Label löschen
     
     'STRASSE
     If InStr(AC, " STRASSE") Then
        Label = "  STRASSE"
        AC.Offset(0, 2) = "  STRASSE"
     ElseIf InStr(AC, "STRASSE") Then
        Label = " STRASSE"
        AC.Offset(0, 2) = "STRASSE"
     End If
     
     'STRA?E
     If InStr(AC, " STRA?E") Then
        Label = "  STRA?E"
        AC.Offset(0, 2) = "  STRA?E"
     ElseIf InStr(AC, "STRA?E") Then
        Label = " STRA?E"
        AC.Offset(0, 2) = "STRA?E"
     End If
   
     'STR. mit Punkt
     If InStr(AC, " STR.") Then
        Label = Label & ",  STR."
        AC.Offset(0, 2) = "  STR."
     ElseIf InStr(AC, "STR.") Then
        Label = Label & ",STR."
        AC.Offset(0, 2) = "STR."
     
     'STR  (ohne Punkt)
     If InStr(AC, "STRASSE") = 0 Then
     ElseIf InStr(AC, "STR.") Then
     ElseIf InStr(AC, " STR") Then
        Label = Label & ",  STR"
        AC.Offset(0, 2) = "  STR"
     ElseIf InStr(AC, "STR") Then
        Label = Label & ",STR"
        AC.Offset(0, 2) = "STR"
     End If
     End If
     
     If InStr(AC, " WEG") Then
        Label = Label & ",  WEG"
        AC.Offset(0, 2) = "  WEG"
     ElseIf InStr(AC, "WEG") Then
        Label = Label & ",WEG"
        AC.Offset(0, 2) = "WEG"
     End If
       
     'GASSE
     If InStr(AC, " GASSE") Then
        Label = Label & ",  GASSE"
        AC.Offset(0, 2) = "  GASSE"
     ElseIf InStr(AC, "GASSE") Then
        Label = Label & ",GASSE"
        AC.Offset(0, 2) = "GASSE"
     End If
       
     'ALLEE
     If InStr(AC, " ALLEE") Then
        Label = Label & ",  ALLEE"
        AC.Offset(0, 2) = "  ALLEE"
     ElseIf InStr(AC, "ALLEE") Then
        Label = Label & ",ALLEE"
        AC.Offset(0, 2) = "ALLEE"
     End If
 
     'CHAUSSE
     If InStr(AC, " CHAUSSE") Then
        Label = Label & ",  CHAUSSE"
        AC.Offset(0, 2) = "  CHAUSSE"
     ElseIf InStr(AC, "CHAUSSE") Then
        Label = Label & ",CHAUSSE"
        AC.Offset(0, 2) = "CHAUSSE"
     End If
 
     '1. Komma in Label abschneiden
     Label = Trim(Mid(Label, 2, 100))
     
     'auflisten wenn 2. Strasse in Label
     If InStr(Label, ",") Then
        AC.Offset(0, 2).Cells(1, 2) = Label
     End If
  Next AC
End Sub

[radagast]

excelfreunde, gast123,

den teil im makro bitte anpassen:

Code:

     'CHAUSSEE
     If InStr(AC, " CHAUSSEE") Then
        Label = Label & ",  CHAUSSEE"
        AC.Offset(0, 2) = "  CHAUSSEE"
     ElseIf InStr(AC, "CHAUSSEE") Then
        Label = Label & ",CHAUSSEE"
        AC.Offset(0, 2) = "CHAUSSEE"
     End If

[lycom87]

Hallo,

ich habe die Angewohnheiğt solche Aufgaben immer in einer kopierten Datei zu bearbeiten. Schutz for Datenverlust.

anbei ein kleines Makro mit dem man alle Arten von ;Strassen suchen und sich seitlich in 2 Spalten weiter notieren kann. Diese Spalten müssen natürlich frei sein. Oder den Offset von Offset(0, 2) auf (0, n) erhöhen. Sinn macht es wenn man vorher in Spalte A eine fortlaufende Lauf-Nr einfügt, sich Button zum Sortieren anlegt, und den Datensatz nach Strasse sortiert. Die Lauf-Nr braucht man zum Zurück-Sortieren. Damit findet man all Arten der Strassenangabe. Beim Sortieren blieben die Arten, die man nicht im Mkaro erfasst hat ja übrig. Deshalb sortiere ich gerne zur Kontrolle.

mfg  Gast 123

Code:

Option Explicit      '14.9.2016   Gast 123   für Clever Forum

Const Bereich = "A2:A13"   'deinen Such Bereich angeben

'Modul zum "STRASSE" auflisten

Sub Strassen_ausfiltern()
Dim AC As Object, Label As String
  For Each AC In Range(Bereich)
     Label = Empty   'Label löschen
     
     'STRASSE
     If InStr(AC, " STRASSE") Then
        Label = "  STRASSE"
        AC.Offset(0, 2) = "  STRASSE"
     ElseIf InStr(AC, "STRASSE") Then
        Label = " STRASSE"
        AC.Offset(0, 2) = "STRASSE"
     End If
     
     'STRA?E
     If InStr(AC, " STRA?E") Then
        Label = "  STRA?E"
        AC.Offset(0, 2) = "  STRA?E"
     ElseIf InStr(AC, "STRA?E") Then
        Label = " STRA?E"
        AC.Offset(0, 2) = "STRA?E"
     End If
   
     'STR. mit Punkt
     If InStr(AC, " STR.") Then
        Label = Label & ",  STR."
        AC.Offset(0, 2) = "  STR."
     ElseIf InStr(AC, "STR.") Then
        Label = Label & ",STR."
        AC.Offset(0, 2) = "STR."
     
     'STR  (ohne Punkt)
     If InStr(AC, "STRASSE") = 0 Then
     ElseIf InStr(AC, "STR.") Then
     ElseIf InStr(AC, " STR") Then
        Label = Label & ",  STR"
        AC.Offset(0, 2) = "  STR"
     ElseIf InStr(AC, "STR") Then
        Label = Label & ",STR"
        AC.Offset(0, 2) = "STR"
     End If
     End If
     
     If InStr(AC, " WEG") Then
        Label = Label & ",  WEG"
        AC.Offset(0, 2) = "  WEG"
     ElseIf InStr(AC, "WEG") Then
        Label = Label & ",WEG"
        AC.Offset(0, 2) = "WEG"
     End If
       
     'GASSE
     If InStr(AC, " GASSE") Then
        Label = Label & ",  GASSE"
        AC.Offset(0, 2) = "  GASSE"
     ElseIf InStr(AC, "GASSE") Then
        Label = Label & ",GASSE"
        AC.Offset(0, 2) = "GASSE"
     End If
       
     'ALLEE
     If InStr(AC, " ALLEE") Then
        Label = Label & ",  ALLEE"
        AC.Offset(0, 2) = "  ALLEE"
     ElseIf InStr(AC, "ALLEE") Then
        Label = Label & ",ALLEE"
        AC.Offset(0, 2) = "ALLEE"
     End If
 
     'CHAUSSE
     If InStr(AC, " CHAUSSE") Then
        Label = Label & ",  CHAUSSE"
        AC.Offset(0, 2) = "  CHAUSSE"
     ElseIf InStr(AC, "CHAUSSE") Then
        Label = Label & ",CHAUSSE"
        AC.Offset(0, 2) = "CHAUSSE"
     End If
 
     '1. Komma in Label abschneiden
     Label = Trim(Mid(Label, 2, 100))
     
     'auflisten wenn 2. Strasse in Label
     If InStr(Label, ",") Then
        AC.Offset(0, 2).Cells(1, 2) = Label
     End If
  Next AC
End Sub

Hallo,
schaut schon mal spannend aus ::)  
kannst du mir das bitte einbauen ich bekomme es irgendwie nicht hin .

1000 Dank!!!

[Gast 123]

Hallo

anbei die Beispieldatei mit erweitertem Makro für Strasse und Sortiermarko zurück. Man bekommt durch das Sortieren mehr Übersicht. Einige Fehler die ich erkannte werden als eigener Begriff ausgefiltert, wie z.B. GmbH anstatt Strasse. Beim speichern meckerte mein PC das er nicht alles speichern konnte. Aktive Steuerelemente könnten fehlen  (Excel 2007)  Die Makros laufen aber.

Bei Strasse unterscheide ich Strasse direkt am Wort, ohne Leerzeichen, und Strasse oder Weg etc. mit Leerzeichen.  Eindeutige Fehler wie "STZR" oder "ASSE" sind in der Fehlerspalte erfasst. 

mfg  Gast 123