Adres, postcode en de stad filteren uit adressenlijst.

[VictorT78]

Ik zit met het volgende probleem...

Voor zo'n 5000 adressen dien ik het adres, de postcode en de stad gefilterd te krijgen.

Momenteel is het format als volgt:
Jacob Cats straat 102 a 3035ph rotterdam
Grote Beer 115 1188 BD Amstelveen
Molengatpad 37 1317 BA Almere
Platte driedijk 2 3194KC Hoogvliet

Deze adressen dien ik het volgende format (csv) te krijgen:
Jacob Cats straat 102 a,3035ph,rotterdam
Grote Beer 118,1188 BD,Amstelveen
Molengatpad 17,1317 BA,Almere
Platte driedijk 23,3194KC,Hoogvliet

Zoals je ziet is de ene keer de postcode XXXX AB, de andere keer XXXXAB.
Kopzorgen en breinbrekers alom, kom ik er niet aan uit binnen Excel.

Any help wordt zeer op prijs gesteld :thumb:

 

[edmoor]

Je voorbeeld zegt niet zoveel zonder een voorbeeld document.

 

[gast0158]

Zijn de bewoners van de Grote Beer verhuisd naar de overkant van de straat ?

 

[edmoor]

Scherp

 

[JeanPaul28]

Met een macro die alle postcodes met spatie,de spatie wist, maar dan is er eerst een voorbeeld bestand gewenst zoals eerder al vermeld door Edmoor.

 

[VictorT78]

Bijgevoegd de bestanden.
Adressen_Oud.xlsx is de huidige situatie.
Adressen_Nieuw.xlsx is het nieuwe gewenste format.Bekijk bijlage Adressen_Oud.xlsxBekijk bijlage Adressen_Nieuw.xlsx

 

[edmoor]

Dus de Oud is zoals je het hebt en de Nieuw is zoals je het wilt hebben?

Doe in de Oud eens dit achter een knopje:

Sub Oud2Nieuw()
    Dim adres() As String
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    For i = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Rows.Count
        adres = Split(Cells(i, 1).Value, ",", , vbBinaryCompare)
        Cells(i, 2) = Trim(adres(0))
        Cells(i, 3) = Trim(adres(1))
        Cells(i, 4) = Trim(adres(2))
        If Len(Cells(i, 3)) = 6 Then Cells(i, 3) = Left(Cells(i, 3), 4) & " " & Right(Cells(i, 3), 2)
    Next
    
    ActiveSheet.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[MirjamHelp]

Of zonder VBA maar met de ingebouwde Excel Wizard - Tekst naar Kolommen
Selectie maken in oud van de kolom met de adressen (cellen A1:A5)
Tabbald Gegevens, knop Tekst naar Kolommen
Wizard verschijnt
stap 1 van 3: 'Gescheiden' kiezen, Volgende
stap 2 van 3: Bij scheidingstekens alleen vinkje plaatsen voor 'Komma', rest niet aanvinken, Volgende
stap 3 van 3: Voltooien.

Blijf je alleen met onnodige spaties zitten in de kolom met postcode. Die kan je dan met zoeken/vervangen (CTRL-H) verwijderen.

Gr. Mirjam

 

[edmoor]

@Victor:

De verwarring m.b.t. wel of geen spatie in de postcode komt omdat je voorbeelden in #1 afwijken van de voorbeeld documenten zoals je die in #6 plaatste. In #1 ben je daar trouwens ook niet consequent in. Ook de plaats van de komma's wijkt af. Je eerste voorbeeld set in #1 is totaal anders dan in het document Adressen_Oud.xlsx. Het stukje code dat ik plaatste werkt conform de voorbeelden in #6.

Zo zie je maar weer het belang van goede voorbeelden en duidelijke vraagstelling.

 

[VictorT78]

Mea culpa,

U heeft inderdaad gelijk.
Het Adressen_Oud.xlsx was onjuist.
Hier bevinden zich komma's in.
Deze horen er inderdaad niet in te staan.
Dat zou inderdaad mijn probleem een stuk eenvoudiger maken

Bijgevoegd dit maal het juiste "Oud" bestand genaamd: Adressen_Oud_updated.xlsx

Dus voor de duidelijkheid.
De huidige situatie is: Adressen_Oud_updated.xlsx
De wenselijke nieuwe situatie is: Adressen_Nieuw.xlsx

Maar goed, ik kan me zo voorstellen dat het animo inmiddels wat minder is geworden om mij te helpen...

Bekijk bijlage Adressen_Oud_updated.xlsx Bekijk bijlage Adressen_Nieuw.xlsx

 

[edmoor]

Doe dan dit maar eens achter een knopje:

Sub Oud2Nieuw()
    Dim adres() As String
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    For i = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Rows.Count
        adres = Split(Cells(i, 1).Value, " ", , vbBinaryCompare)
        Cells(i, 2) = Trim(adres(0)) & " " & Trim(adres(1))
        Cells(i, 3) = Trim(adres(2))
        If UBound(adres) = 3 Then
            Cells(i, 3) = Left(Cells(i, 3), 4) & " " & Right(Cells(i, 3), 2)
            Cells(i, 4) = Trim(adres(3))
        Else
            Cells(i, 3) = Trim(adres(2)) & " " & Trim(adres(3))
            Cells(i, 4) = Trim(adres(4))
        End If
    Next
    
    ActiveSheet.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

Ik heb je eigen voorbeeld voorzien van een knopje met bovenstaande code erachter. Test het maar eens.
Bekijk bijlage Adressen_Oud_updated.xlsm

 

[MirjamHelp]

Beste Edmoor (en andere geïnteresseerden),

Wat te doen met voorbeelden als onderstaande adressen?
Blaaksche Dijk 1 1234BB Den Haag.
Blaaksche Dijk 999 A 1234BB Den Haag
Tweede Sint Jansweg 28b 9999 ZZ Land en Maas

En dan, het zal in NL niet vaak voorkomen, maar een huisnummer met 4 cijfers?

Gr. Mirjam

 

[edmoor]

Daar heb je helemaal gelijk in Mirjam, ik ben alleen uitgegaan van de voorbeeld documenten.
Wel goed dat je het even noemt, dan kan TS er rekening mee houden.

 

[VictorT78]

U helpt. Fijn

Ik heb de macro gedraaid en deze lijkt het in de meeste gevallen het goed te doen.
Maar hij lijkt zich ook meerdere malen te "verslikken". Hier komt denk ik de opmerking van Mirjam inderdaad tot zijn recht.

Bijgevoegd de ge-update xlsm. Dit keer met wat meer adressen.

Bekijk bijlage Adressen_Oud_updated_01.xlsm

 

[edmoor]

Het voorbeeld dat ik maakte werkt alleen op de voorbeelden in het eerdere document omdat hij uit moet gaan van spaties. Ieder andere opmaak zal het verstoren. Komen deze adressen uit een ander systeem of zijn ze zo in Excel ingevoerd?

 

[VictorT78]

Komen uit een ander systeem.
Binnen dit systeem is er helaas geen mogelijkheid om het formaat van de export te wijzigen.

 

[MirjamHelp]

Code van Edmoor heb ik iets uitgebreid.

Let wel op wanneer er huisnummers voorkomen die bestaan uit 4 cijfers, dan zal onderstaande code het huisnummer voor de postcode aanzien!

Kijk maar eens hoever je ermee komt.

gr. Mirjam

Sub Oud2Nieuw()
    Dim adres() As String
    Dim i As Long
    Dim blnHerhaal As Boolean
    
    Application.ScreenUpdating = False
    
    For i = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Rows.Count
        adres = Split(Cells(i, 1).Value, " ", , vbBinaryCompare)
        blnHerhaal = Not IsNumeric(Left(adres(2), 4)) Or Len(adres(2)) < 4
        If blnHerhaal = True Then
            Do While blnHerhaal
                adres(1) = adres(1) & " " & adres(2)
                For x = 2 To UBound(adres) - 1
                    adres(x) = adres(x + 1)
                Next x
                If x > 2 Then
                    ReDim Preserve adres(x - 1)
                    blnHerhaal = Not IsNumeric(Left(adres(2), 4)) Or Len(adres(2)) < 4
                Else
                    adres(x) = vbNullString
                    blnHerhaal = False
                End If
            Loop
        End If
        If Len(adres(2)) = 4 Then
            If Len(adres(3)) = 2 Then
                adres(2) = adres(2) & " " & adres(3)
                adres(3) = adres(4)
                ReDim Preserve adres(3)
            End If
        End If
        Cells(i, 2) = Trim(adres(0)) & " " & Trim(adres(1))
        Select Case Len(adres(2))
            Case 4
                Cells(i, 3) = adres(2)
                Cells(i, 5) = "Buitenland"
            Case 6, 7
                Cells(i, 3) = Left(adres(2), 4) & " " & UCase(Right(adres(2), 2))
            Case Else
                With Cells(i, 3)
                    .Value = "PC onjuist formaat"
                    .Interior.Color = 255
                End With
        End Select
        For x = 3 To UBound(adres)
            Cells(i, 4) = Cells(i, 4) & " " & Trim(adres(x))
        Next x
    Next
    
    ActiveSheet.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[VictorT78]

Mees-ter-lijk Mirjam!

Uitstekende klasse!

Mijn dank is 1000 x :love: voor zowel Mirjam en edmoor.
Saves me a lot of time.

 

[Peter B]

Ik was hier inmiddels ook mee aan het stoeien, en wil dan jullie ook mijn code (eerlijk is eerlijk; geïnspireerd door mijn collega helpers) niet onthouden. Dit enerzijds omdat ik ook bezig was (maar ik kennelijk minder snel ben), anderzijds omdat ik zag dat regel 15 nog fout gaat in omzetting met de code van MirjamHelp ("Den Haag" wordt "Den"). Ook meen ik een oplossing te hebben m.b.t. eventuele 4 cijferige huisnummers. De truc die ik hierbij gebruik is dat ik alle cijfers uit de adres-string haal en hier mee aan de slag ga. Het enige probleempje wat ik nu nog zie is postcodes met 4 cijfers, maar zonder letters, gevolgd door een plaatsnaam die bestaat uit meer dan 1 woord waarbij het eerste woord 2 karakters lang is. Bv. "De Meern".

Hierbij mijn inbreng:

Sub Oud2Nieuw()
    Dim num, straatnum, pc, plaats, adres, hulp As String
    Dim i, j As Long

    Application.ScreenUpdating = False

    For i = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Rows.Count

        num = 0

        adres = Cells(i, 1).Value

        If Len(adres) > 0 Then
'       Haal alle getallen uit het adres en plaats deze in één string
            For j = 1 To Len(adres)
                If IsNumeric(Mid(adres, j, 1)) Then
                    num = num * 10 + Mid(adres, j, 1)
                End If
            Next j

            pc = Right(num, 4)
            If InStr(1, adres, pc, vbTextCompare) = 0 Then
                Cells(i, 3) = "LET OP! Postcode heeft geen 4 cijfers"
            Else
                straatnum = Mid(adres, 1, InStr(1, adres, pc, vbTextCompare) - 2)
                plaats = LTrim(Right(adres, Len(adres) - InStr(1, adres, pc, vbTextCompare) - 6))
                pc = Replace(pc & Mid(adres, InStr(1, adres, pc, vbTextCompare) + 4, 3), " ", "")
                hulp = Right(pc, 2) & " "
                If InStr(1, adres, hulp, vbTextCompare) = 0 Then
                    plaats = Right(pc, 2) & plaats
                    pc = Left(pc, 4)
                    Cells(i, 5).Value = "Buitenland"
                End If

                Cells(i, 2).Value = straatnum
                Cells(i, 3).Value = UCase(pc)
                Cells(i, 4).Value = plaats

            End If

        End If

    Next i

    ActiveSheet.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True

End Sub

 

[alphamax]

Er zit zoveel variatie in de nederlands NAW-gegevens, dat je met de beste code, nooit een 100% oplossing krijgt.
Houd daar dus rekening mee.