Trennung von Informationen, schwer

[Statistik]

Hallo zusammen,

ich versuche folgendes zu realisieren:

Spalte A: Steht ein Straßenname
Spalte B: Hausnummer
Spalte C: Hausnummer Zusatz
Spalte D: Bezirk


jetzt versuche ich Folgendes Trennung der Spalten in:

A: Straßenname
B: gerade von

c: gerade Hausnummernzusatz von
D: gerade bis
E: gerade Hausnummernzusatz bis
F: ungerade von
G: ungerade Hausnummernzusatz von
H: ungerade bis
I: ungerade Hausnummernzusatz bis
J: Bezirk



ist dies zu realisieren bei ca. 40000 Einträgen?
Anbei ein Auszug (Mappe 1 ausgangszustand, Mappe 2 gewünschtes Ziel.

[Elex]

Hi

sollte machbar sein.

Nachfrage.
Wenn schon zusammenfassen, warum dann 2mal "An der Untertrave" "Stat. Bez. 01.8" in der Bsp. Datei.

Gruß Elex

[MisterBurns]

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.

[Ego]

Hallo S...,

kann es vorkommen, dass nur ein mittlerer Teil einer Strasse in einem anderen Bezirk liegt?

Dann ist die Sortierung nach Strasse, Bezirk, Hausnummer nicht ausreichend.

[Statistik]

[
Bild bitte so als Datei hochladen: Klick mich!
]
Lieber Ego,

ja es kann durchaus vorkommen.

Anbei eine bessere Mappe die das Problem illustriert.

Danke für den ersten  Codeansatz MisterBurns:

dieser gab jedoch folgende Fehlermeldung (siehe oben)



Viele Grüße!

[MisterBurns]

1. Es bringt leider nichts, wenn du ein Bild von der gelben Zeile postest, ohne die Fehlermeldung selbst bekanntzugeben.

2. Ich habe meinen Code 1:1 in deine neue Datei eingefügt und laufen lassen - kein einziges Problem festgestellt. Anbei die Datei inkl. Code. Lass ihn laufen, es wird keine Fehlermeldung geben

3. Wenn du schon ein verbessertes Beispiel hochlädst, sollte auch das Ergebnis stimmen. Ich bekomme für Braunschweig Allee 5 verschiedene Ergebniszeilen, da auch 5 Bezirke (02.1 bis 02.4 sowie 09.0)

[Elex]

Hi

Der Code von @MisterBurns läuft unter Excel 2010 wenn du in der gelben Zeile und den weiteren hinter Add die 2 entfernst.

Gruß Elex

[Ego]

Hallo S,

ich habe meine Frage nicht deutlich genug formuliert. Dein zweites Beispiel ist auch mit Bernis Algorithmus lösbar.

Ein neuer Versuch:

Kann es vorkommen, dass ein vorderer Teil einer Strasse zu einem Bezirk, der nächste Teil zu einem anderen und dann wieder ein Teil kommt, der zum ersteren Bezirk gehört?

[snb]

Scheint mir eine typische 'Dictionary' Aufgabestellung zu sein:

Code:

Sub M_snb()
   sn = Tabelle3.Cells(1).CurrentRegion
   
   With CreateObject("scripting.dictionary")
      For j = 1 To UBound(sn)
        t = sn(j, 2) Mod 2 = 0
        sp = Array(sn(j, 1), IIf(t, sn(j, 2), ""), IIf(t, sn(j, 3), ""), "", "", IIf(t, "", sn(j, 2)), IIf(t, "", sn(j, 3)), "", "", sn(j, 4))
        If .exists(sn(j, 1) & sn(j, 4)) Then
           st = .Item(sn(j, 1) & sn(j, 4))
           If t Then
              If sp(1) < st(1) Then
                st(1) = sp(1)
                st(2) = sp(2)
              End If
              If sp(1) > Val(st(3)) Then
                st(3) = sp(1)
                st(4) = sp(2)
              End If
           End If
           If Not t Then
              If sp(5) < st(5) Then
                 st(5) = sp(5)
                 st(6) = sp(6)
              End If
              If sp(5) > Val(st(7)) Then
                st(7) = sp(5)
                st(8) = sp(6)
              End If
           End If
        Else
           st = sp
        End If
         .Item(sn(j, 1) & sn(j, 4)) = st
      Next
      Tabelle2.Cells(10, 1).Resize(.Count, UBound(sp) + 1) = Application.Index(.items, 0, 0)
    End With
End Sub