postcode door numeriek met alfanumeriek te splitsen d.m.v. vba

[Robert Smidt]

Beste mensen,

Ik heb een bestand in Excel waar in kolom M postcodes staan. Nu staan de letters en nummers aan elkaar geschreven (1234AB). Ik zou graag een code willen ontvangen dat de postcodes in kolom M wijzigt in letters en nummers gescheiden door een spatie (1234 AB).

Alvast hartelijk bedankt voor de medewerking.

Groeten,
Robert

 

[Thoralf]

=LINKS(M1;4)&" "&RECHTS(M1;2)

zou het moeten doen.

 

[rntm]

In VBA:

Sub Macro1()
  Application.ScreenUpdating = False
  With Sheets(1)
    Y = .Range("M" & Rows.Count).End(xlUp).Row
  End With
  Range("N1").Select
  Selection.EntireColumn.Insert
  For X = 1 To Y
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],4)&"" ""&UPPER(RIGHT(RC[-1],2))"
    Selection.Copy
    ActiveCell.Offset(0, -1).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(1, 1).Range("A1").Select
  Next X
  Selection.EntireColumn.Delete
  Application.ScreenUpdating = True
End Sub

Succes,
Ronald

 

[Robert Smidt]

bedankt

Ronald,

Bedankt voor jouw reactie, ik ga morgen op het werk kijken of de code werkt.

Nogmaals bedankt.

Wordt vervolgd.

Groet, Robert

 

[Warme bakkertje]

Of deze. Beide functies kan je eventueel ooit ook nog eens ergens anders voor gebruiken

Sub tst2()
For Each cl In Range(Range("M1"), Range("M" & Rows.Count).End(xlUp))
    cl.Value = ExtractNumber(Range(cl.Address)) & " " & ExtractAlpha(Range(cl.Address))
Next
End Sub
Function ExtractNumber(rC As Range) As String
'Geeft enkel cijfers uit celwaarde
    With CreateObject("VBSCRIPT.REGEXP")
        .Pattern = "[^0-9]"
        .Global = True
        .IgnoreCase = True
        ExtractNumber = .Replace(rC.Value, "")
    End With
End Function
Function ExtractAlpha(rC As Range) As String
'Geeft enkel letters uit celwaarde
    With CreateObject("VBSCRIPT.REGEXP")
        .Pattern = "[^a-z]"
        .Global = True
        .IgnoreCase = True
        ExtractAlpha = .Replace(rC.Value, "")
    End With
End Function

 

[Robert Smidt]

Helaas werkt niet

Dag Ronald

In antwoord op jou oplossing.

Onderstaande heb ik op het werk geprobeerd maar werkt helaas niet, bovendien wordt er een kolom verwijderd die niet verwijderd mag worden. Ik heb de code wat aangepast zodat er geen verkeerde kolommen worden verwijderd (zie onderstaande) maar werkt nog steeds niet. Is het mogelijk dat je de inhoud niet naar een ander kolom hoeft te kopiëren?

Ik ga maandag kijken of de andere oplossing - de ik inmiddels heb gekregen - werkt.

Nogmaals bedankt en zie een reactie met belangstelling tegemoet.

Groet, Robert

Application.ScreenUpdating = False
With Sheets(1)
Y = .Range("M" & Rows.Count).End(xlUp).Row
End With
Range("m1").Select
Selection.EntireColumn.Insert
For x = 1 To Y
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],4)&"" ""&UPPER(RIGHT(RC[-1],2))"
Selection.Copy
ActiveCell.Offset(0, -1).Range("bc1").Select
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 1).Range("bc1").Select
Next x
Selection.EntireColumn.Delete
Application.ScreenUpdating = True

 

[oeldere]

Robert,

graag de code in tags zetten (met het #)

 

[Cobbe]

Deze moet toch voldoende zijn om deze klus te klaren:

Sub cobbe()
Dim cl As Range
 For Each cl In Range("M1:M" & Range("M" & Rows.Count).End(xlUp).Row)
   If Len(cl) = 6 Then cl = Left(cl, 4) & " " & Right(cl, 2)
 Next
End Sub

 

[HSV]

Of.

Sub hsv()
Dim cl As Range
For Each cl In Columns(13).SpecialCells(2)
  If Len(cl) = 6 Then
    cl.Characters(5, 0).Insert (" ")
   End If
 Next cl
End Sub

 

[Robert Smidt]

wordt vervolgd

Heren,

Hartelijk bedankt voor jullie oplossing dit waardeer ik enorm.

Ik zal dit vandaag op het werk uitproberen en zal julli hiervan in kennis stellen of dit het gewenste resultaat oplevert waar ik zeker vanuit ga.

Nogmaals hartelijk bedankt.

Groet, Robert

 

[Warme bakkertje]

Dan zou ik ipv op lengte (kan dan vanalles zijn, als de lengte maar goed is) toch controleren op inhoud

Sub tst2()
For Each cl In Columns(13).SpecialCells(2)
    With CreateObject("VBScript.RegExp")
        .Global = False
        .Pattern = "^[0-9]{4}[a-z|A-Z]{2}$"
        If .Test(CStr(cl)) Then
            cl.Characters(5, 0).Insert (" ")
        Else
        'hier kan je een actie plaatsen als een foutieve postcode wordt gevonden
        End If
    End With
Next
End Sub

 

[snb]

Zo, zo, ben je je aan het verdiepen in regular expressions ?

waarom niet ?

[N1:N2000]=[if(M1:M2000="","",left(M1:M2000,4) & " " & RIGHT(M1:M2000;2))]

of een UDF (in een macromodule):

Function pc_snb(c01)
    pc_snb = Format(c01, "@@@@ @@")
End Function

in cel N1 bijv: =pc_snb(M1)

 

[Warme bakkertje]

Zo is het natuurlijk rechttoe rechtaan, maar mij was het er eerder om te doen om bij wijze van oefening (dat baart kunst wordt gezegd) een controle op de celinhoud in te voeren.

 

[Robert Smidt]

de code werkt perfect

Heren,

Ik ben aagenaam verrast van de goede oplossingen die ik heb mogen ontvangen. Ze werken allemaal en met de toevoeging kan en ga ik zeker mijn voordeel doen.

Nogmaals heel hartelijke bedankt.

Groet, Robert