Splitting textstring (adress) into seperate columns

Maybe:

Sub soli004yy()
Dim rcell As Range
Range("A2:A" & Range("A" & Rows.count).End(3)(1).Row).Select
    Selection.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
For Each rcell In Range("B2:B" & Range("A" & Rows.count).End(3)(1).Row)
    If Len(rcell) > 3 Then
        rcell.offset(, -1).Value = rcell.offset(, -1).Value & rcell.Value
        rcell.offset(, 1).Cut rcell
    End If
Next rcell
For Each rcell In Range("B2:B" & Range("A" & Rows.count).End(3)(1).Row)
    If Not IsNumeric(rcell) Then
        rcell.offset(, 1).Value = Right(rcell, 1)
        rcell.Value = Left(rcell, Len(rcell) - 1)
    End If
Next rcell
End Sub

Try the attached

Originally Posted by jindon

Try the attached

Works fantastic!!

But how to implement if you have data in other cells?

Addresses are actually in column "F" and I have data in cells from column A to S.

I tried to insert two extra columns after "F" and had the first address selected then run your code, no success...

How can I make it work from the "F" column?

Thanks for fast reply!

Data in Col.F, output to G:I ?
change to

Sub test()
    Dim a, i As Long
    With Range("f1", Range("f" & Rows.Count).End(xlUp)).Resize(, 4)
        a = .Value
        .Offset(1, 1).ClearContents
        With CreateObject("VBScript.RegExp")
            .Pattern = "^(.+) (\d+) *(\D+)?$"
            For i = 2 To UBound(a, 1)
                If .test(a(i, 1)) Then
                    a(i, 2) = .Replace(a(i, 1), "$1")
                    a(i, 3) = .Replace(a(i, 1), "$2")
                    a(i, 4) = .Replace(a(i, 1), "$3")
                End If
            Next
        End With
        .Value = a
    End With
End Sub

Great!

Thanks!