Line spitting with specific characteristics

[manosalexo]

Hello there.

I have a situation.
Every once a month i have to deal with some addresses.
I have managed so far to remove some useless information like this

ΗΡΑΚΛΕΙΔΩΝ 36 ΑΘΗΝΑ 11851 ΑΤΤΙΚΗΣ

ΗΡΩΩΝ ΠΟΛΥΤΕΧΝΕΙΟΥ 23 ΑΓ.ΣΤΕΦΑΝΟΣ 14565 ΑΤΤΙΚΗΣ

ΠΥΡΓΙΩΤΙΣΣΗΣ 29 ΠΕΡΙΣΤΕΡΙ 12136 ΑΤΤΙΚΗΣ

ΤΡΥΠΙΑ 26 Β ΠΕΥΚΗ 15121 ΑΤΤΙΚΗΣ

EYΓENΩN 5 - ΠEPIΣTEPI 12134 Result: ΗΡΑΚΛΕΙΔΩΝ 36 ΑΘΗΝΑ ΗΡΩΩΝ ΠΟΛΥΤΕΧΝΕΙΟΥ 23 ΑΓ.ΣΤΕΦΑΝΟΣ ΠΥΡΓΙΩΤΙΣΣΗΣ 29 ΠΕΡΙΣΤΕΡΙ ΤΡΥΠΙΑ 26 Β ΠΕΥΚΗ EYΓENΩN 5 ΠEPIΣTEPI Now i want to line split to the next column anything that is right of the number value. I have been using this line of code: <colgroup><col></colgroup><tbody> </tbody>

<colgroup><col></colgroup><tbody>
</tbody>

Dim allCombi As String
    Dim allArrCombi(), allAftCombi()  As String
    
    
    
    sourceADR = Worksheets("CASE").Range("N" & i).Value
    
     Worksheets("MAIN_CONTROL").Cells(i, 25).Value = sourceADR
    
    sourceADR = Replace(sourceADR, "ÁÔÔÉÊÇÓ", "")
    


    
    '...................................................................
     sourceADR = Replace(sourceADR, "-", " ")
     sourceADR = Replace(sourceADR, "  ", " ")
     sourceADR = Trim(sourceADR)
     
    
     auxC = sourceADR
     
     
Worksheets("MAIN_CONTROL").Cells(i, 26).Value = sourceADR
 '..............................
     If (Len(sourceADR) < 1) Then GoTo aseAddr
 '..............
    mainAddress = Split(sourceADR)
     
     addrAA = ""
   Worksheets("MAIN_CONTROL").Cells(i, 24).Value = Str(UBound(mainAddress)) & "@@" & Str(LBound(mainAddress))
     
     
     For jA = UBound(mainAddress) To LBound(mainAddress) Step -1
     
    
    '......................................................
    
    
   If (regex.Test(Trim(mainAddress(jA)))) Then
   
   
   auxC = Replace(auxC, Trim(mainAddress(jA)), "")
    destws.Range("BT" & i).Value = Trim(mainAddress(jA))
    destws.Range("AA" & i).Value = Trim(mainAddress(jA))
    'destws.Range("Z" & i).Value = addrAA


   auxC = Trim(auxC)
    destws.Range("Y" & i).Value = auxC
    destws.Range("Z" & i).Value = addrAA
  '--------------------------------------------------------
   
'-------------------------------------------------------
   
   GoTo aseAddr
   
   
    End If
 
  


   
   auxC = Replace(auxC, Trim(mainAddress(jA)), "")
   addrAA = mainAddress(jA) & " " & addrAA
   
   
   
   
        
          
       
    
  '
    
    '.....................................................
    Next jA

Could anyone please help me?
Thanks in advance

 

[DanteAmor]

The code is not complete, you could better explain what you have and what you expect of result.

 

[manosalexo]

The code is not complete, you could better explain what you have and what you expect of result.

Ok so, i have a column with addresses like
Kountouri 35 Athens
Ag.ioannou 55 kallithea
Patriarxou makariou 6A Agios Dimitrios
Karaoli dimitriou 112 Agios Antonios.

What i want to do is to split to the next column anything after the number value.

Note that some number values may have a single letter string even with a space between. This single letter must be in the same column with the number value

 

[DanteAmor]

Try the following, your data in column N of row 2 down, the results will be in columns Y and Z

Sub Extract_Text()
    Dim sh As Worksheet, cell As Range, rng As Range
    Dim k As Double, num As Boolean, cad As String
    
    Set sh = Sheets("CASE")
    Set rng = sh.Range("N2", sh.Range("N" & Rows.Count).End(xlUp))
    
    For Each cell In rng
        num = False
        cad = ""
        For k = 1 To Len(cell.Value)
            If Mid(cell.Value, k, 1) Like "[0-9]" Then
                cad = Mid(cell.Value, 1, k)
                num = True
            Else
                If num Then
                    If Mid(cell.Value, k, 1) <> " " Then cad = Mid(cell.Value, 1, k)
                    Exit For
                End If
            End If
        Next
        
        sh.Cells(cell.Row, "Y").Value = cad
        sh.Cells(cell.Row, "Z").Value = WorksheetFunction.Trim(Mid(cell.Value, Len(cad) + 1))
    
    Next
    
    MsgBox "End"
    
End Sub

 

[manosalexo]

Try the following, your data in column N of row 2 down, the results will be in columns Y and Z

Sub Extract_Text()
    Dim sh As Worksheet, cell As Range, rng As Range
    Dim k As Double, num As Boolean, cad As String
    
    Set sh = Sheets("CASE")
    Set rng = sh.Range("N2", sh.Range("N" & Rows.Count).End(xlUp))
    
    For Each cell In rng
        num = False
        cad = ""
        For k = 1 To Len(cell.Value)
            If Mid(cell.Value, k, 1) Like "[0-9]" Then
                cad = Mid(cell.Value, 1, k)
                num = True
            Else
                If num Then
                    If Mid(cell.Value, k, 1) <> " " Then cad = Mid(cell.Value, 1, k)
                    Exit For
                End If
            End If
        Next
        
        sh.Cells(cell.Row, "Y").Value = cad
        sh.Cells(cell.Row, "Z").Value = WorksheetFunction.Trim(Mid(cell.Value, Len(cad) + 1))
    
    Next
    
    MsgBox "End"
    
End Sub

Thanks for answering.
There seems to be a problem with that.
It stops when it finds the first number.
For example it prints:
Kountouri 3
Ag.ioannou 5
Patriarxou makariou 6
Karaoli dimitriou 1

 

[manosalexo]

DanteAmor
Note: i adjusted your code to be like this:


auxC = Trim(auxC)
For k = 1 To Len(auxC)
If Mid(auxC, k, 1) Like "[0-9]" Then
auxC = Mid(auxC, 1, k)
Else
If Mid(auxC, k, 1) <> " " Then cad = Mid(auxC, 1, k)
End If
Next k


destws.Range("Y" & i).Value = auxC
destws.Range("Z" & i).Value = Trim(Mid(auxC, Len(auxC) + 1))

 

[manosalexo]

Ok i just corrected the number values If Mid(cell.Value, k, 1) Like "[0-999]" Then

The problem that remains is that column Z won't print anything at all

 

[DanteAmor]

In post # 2 I asked you for the result, in post # 3 you did not put the result. So I do not know what the expected result is.

 

[manosalexo]

In post # 2 I asked you for the result, in post # 3 you did not put the result. So I do not know what the expected result is.

ok let's see.

I used your code like this

Sub Extract_Text()    Dim sh As Worksheet, cell As Range, rng As Range, rng1 As Range
    Dim k As Double, num As Boolean, cad As String
    
    Set sh = Sheets("cases_P")
    Set rng = sh.Range("Y2", sh.Range("Y" & Rows.Count).End(xlUp))
    
    For Each cell In rng
        num = False
        cad = ""
        For k = 1 To Len(cell.Value)
            If Mid(cell.Value, k, 1) Like "[0-999]" Then
                cad = Mid(cell.Value, 1, k)
                num = True
                
            ElseIf num Then
                'If num Then
                    If Mid(cell.Value, k, 1) <> " " Then cad = Mid(cell.Value, 1, k)
                  '  Else
               ' ElseIf num Then
                     'ElseIf Mid(cell.Value, k, 1) Like "[0-999]" And Mid(cell.Value, k + 2, 1) Like "[0-999]" Then
                   'cad = Mid(cell.Value, 1, k)
                  Exit For
            Else
                cad = cell.Value
           
                 End If
                ' End If
              '  End If
            
            sh.Cells(cell.Row, "Z").Value = WorksheetFunction.Trim(Mid(cell.Value, Len(cad) + 2))
        Next
        
        sh.Cells(cell.Row, "Y").Value = cad
        
    
    Next
    
    MsgBox "End"
    
End Sub

before the coding my column was like this:

ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ

ΚΑΛΛΙΚΡΑΤΙΔΑ 50 ΠΕΙΡΑΙΑΣ

ΚΑΛΛΙΚΡΑΤΙΔΑ 50 ΠΕΙΡΑΙΑΣ

ΑΓΡΙΝΙΟΥ 41 ΓΛΥΦΑΔΑΣ

ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 ΙΛΙΟΥ

ΗΡΩΩΝ ΠΟΛΥΤΕΧΝΕΙΟΥ 23 ΑΓ.ΣΤΕΦΑΝΟΣ

ΑΓΙΑΣ ΠΑΡΑΣΚΕΥΗΣ 66 ΧΑΪΔΑΡΙΟΥ

ΚΑΝΕΛΛΟΠΟΥΛΟΥ 30 ΑΓΙΑΣ ΒΑΡΒΑΡΑΣ

ΠΑΠΑΝΑΣΤΑΣΙΟΥ 84 ΑΘΗΝΑ

ΜΑΚΕΔΟΝΙΑΣ 17 ΑΡΓΥΡΟΥΠΟΛΗ

ΜΑΚΡΥΓΙΑΝΝΗ 113 ΑΓΙΟΣ ΔΗΜΗΤΡΙΟΣ

ΘΗΝΑΙΑΣ 16 ΑΘΗΝΑΙΩΝ

ΤΗΝΟΥ 12 ΑΘΗΝΑ

ΚΥΠΡΙΩΝ ΗΡΩΩΝ 23 ΗΛΙΟΥΠΟΛΗ

ΑΙΓΕΩΣ 7 ΒΟΥΛΑ

ΣΚΟΥΦΑ 49 ΑΙΓΑΛΕΩ

ΝΙΚΟΛΑΟΥ ΠΛΑΣΤΗΡΑ 84 ΝΕΑΣ ΕΡΥΘΡΑΙΑΣ

ΣΩΚΡΑΤΟΥΣ 30 ΔΙΟΝΥΣΟΥ

ΑΓΙΑΣ ΑΝΝΗΣ 32 ΑΓΙΟΣ ΙΩΑΝΝΗΣ ΡΕΝΤΗΣ

ΣΑΠΦΟΥΣ 36 ΚΑΛΛΙΘΕΑ

ΔΡΑΜΑΣ 4 ΜΕΛΙΣΣΙΑ

ΑΡΓΥΡΗ ΕΦΤΑΛΙΩΤΗ 15 ΑΜΑΡΟΥΣΙΟΥ

ΑΘΗΝΑΓΩΡΟΥ 13 ΑΘΗΝΑ

ΔΡΑΓΟΥΜΗ ΙΩΝΟΣ 64 ΠΕΙΡΑΙΑΣ

ΑΝΑΞΑΓΟΡΑ 7 ΓΕΡΑΚΑΣ

ΑΚΡΟΠΟΛΕΩΣ 59 ΝΕΟ ΗΡΑΚΛΕΙΟ

ΡΕΑΣ 8 ΚΑΛΛΙΘΕΑ

ΚΟΙΜΗΣΕΩΣ ΘΕΟΤΟΚΟΥ 36 ΓΕΡΑΚΑ

ΑΡΕΩΣ 42 ΠΑΛΑΙΟΥ ΦΑΛΗΡΟΥ

ΑΓ ΙΕΡΟΘΕΟΥ 35 ΠΕΡΙΣΤΕΡΙ

ΝΑΥΑΡΙΝΟΥ 6 ΧΟΛΑΡΓΟΣ

ΑΛΕΞΑΝΔΡΟΥ ΠΑΝΑΓΟΥΛΗ 24 ΑΓΙΑ ΠΑΡΑΣΚΕΥΗ

ΚΟΥΝΤΟΥΡΙΩΤΟΥ 42 ΧΟΛΑΡΓΟΥ

ΜΥΚΗΝΩΝ 71 ΜΕΓΑΡΑ

ΕΛΑΙΩΝΩΝ 23 ΠΑΛΛΗΝΗΣ

ΑΝΤΩΝΙΟΥ ΦΙΞ 18 ΑΘΗΝΑ/ΠΕΥΚΗ

ΕΛΕΥΘΕΡΙΑΣ 3Α ΑΓΙΟΣ ΙΩΑΝΝΗΣ ΡΕΝΤΗΣ

ΑΡΕΩΣ 51 ΚΗΦΙΣΙΑ

ΝΙΚΟΛΑΟΥ ΠΛΑΣΤΗΡΑ 10 ΠΕΥΚΗΣ

ΣEBAΣTEIAΣ 58 N ΣMYPNH

ΛΕΩΦΟΡΟΣ ΙΩΝΙΑΣ 67 ΑΘΗΝΑΙΩΝ

ΣΙΦΝΟΥ 4Β ΒΑΡΗ

ΚΑΠΕΤΑΝ ΛΑΧΑΝΑ 33 35 ΑΘΗΝΑ

ΣΕΒΔΙΚΙΟΥ 28 ΚΡΥΟΝΕΡΙ

ΘΡΑΚΗΣ 56 ΒΡΙΛΗΣΣΙΩΝ

ΠΑΠΑΦΛΕΣΣΑ 16 ΙΛΙΟΝ

ΠΑΛΑΙΩΝ ΠΑΤΡΩΝ ΓΕΡΜΑΝΟΥ 3 ΠΑΛΑΙΟΥ ΦΑΛΗΡΟΥ

ΑΓΙΟΥ ΟΡΟΥΣ 59 ΜΑΡΟΥΣΙ , Ν.ΦΙΛΟΘΕΗ

ΛΟΧΑΓΟΥ ΡΕΠΕΤΣΑ 7 ΠΕΙΡΑΙΩΣ

ΜΕΓΑΛΟΧΑΡΗΣ 10 ΝΕΑΣ ΜΑΚΡΗΣ

ΕΛΕΥΘΕΡΙΟΥ ΒΕΝΙΖΕΛΟΥ 45 ΚΑΜΑΤΕΡΟ

AΓIAΣ ΠAPAΣKEYHΣ 45 47 ΠEIPAIAΣ

ΛΟΧΑΓΟΥ ΡΕΠΕΤΣΑ 7 ΠΕΙΡΑΙΩΣ

ΟΛΥΜΠΟΥ 93 ΑΝΑΒΥΣΣΟΥ

ΑΥΡΑΣ 32 ΣΑΡΩΝΙΚΟΥ

ΜΠΑΡΟΥΞΗ 56 ΠΕΡΙΣΤΕΡΙΟΥ

ΑΡΕΩΣ 80 ΠΑΛΑΙΟΥ ΦΑΛΗΡΟΥ

ΗΡΑΚΛΕΙΤΟΥ 5 ΓΛΥΦΑΔΑΣ

ΚΡΙΕΖΗ 59 ΑΜΑΡΟΥΣΙΟΥ

ΜΙΑΟΥΛΗ 45 Τ.Θ. 46529 45 ΑΧΑΡΝΕΣ

ΗΡΟΔΟΤΟΥ 10 12 ΚΟΡΥΔΑΛΛΟΣ

ΠΕΙΣΙΣΤΡΑΤΟΥΣ 8 12 ΑΘΗΝΑΙΩΝ

ΗΡΑΚΛΕΙΔΩΝ 36 ΑΘΗΝΑ

ΘΕΜΙΣΤΟΚΛΗ ΣΟΦΟΥΛΗ 10 ΝΕΑΣ ΣΜΥΡΝΗΣ

Λ.ΒΡΑΒΡΩΝΟΣ 5 ΑΡΤΕΜΙΣ

ΔΗΜΗΤΡΙΟΥ ΜΠΙΣΚΙΝΗ 31 ΖΩΓΡΑΦΟΥ

ΜΑΚΕΔΟΝΙΑΣ 11 13 ΚΗΦΙΣΙΑ

ΛΥΚΑΙΟΥ 42 ΑΘΗΝΑ

ΑΓΙΑΣ ΛΑΥΡΑΣ 44 ΝΙΚΑΙΑ

ΛΕΣΒΟΥ 2Γ ΝΙΚΑΙΑ

ΝΙΚΑΙΑΣ 60 ΝΕΑΣ ΣΜΥΡΝΗΣ

ΕΠΙΔΑΥΡΟΥ 42 ΧΑΛΑΝΔΡΙ

ΦΡΥΝΗΣ 20 ΝΕΑΣ ΕΡΥΘΡΑΙΑΣ

ΚΑΝΑΡΗ 3 ΜΕΛΙΣΣΙΑ

ΚΡΙΝΩΝ 8 ΚΑΤΩ ΚΗΦΙΣΙΑ

ΓΕΩΡΓΙΟΥ ΠΑΠΑΝΔΡΕΟΥ 44 ΝΕΑΣ ΦΙΛΑΔΕΛΦΕΙΑΣ

ΑΝΕΞΑΡΤΗΣΙΑΣ 40 ΧΑΪΔΑΡΙ

ΑΓΙΑΣ ΤΡΙΑΔΟΣ 9Α ΧΟΛΑΡΓΟΣ

ΠΑΥΛΟΥ ΜΕΛΑ 128Β ΑΧΑΡΝΩΝ

ΑΛΕΞ ΔΙΑΚΟΥ 23 ΑΘΗΝΑ

ΕΠΙΔΑΥΡΟΥ 56 ΧΑΛΑΝΔΡΙ

ΑΙΟΛΙΔΟΣ 55 ΑΘΗΝΑ

ΑΡΕΩΣ 23 ΜΑΡΟΥΣΙ

ΠΛΑΤΩΝΟΣ 24 ΚΗΦΙΣΙΑ

ΒΑΣΙΛΕΙΟΥ ΒΟΥΛΓΑΡΟΚΤΟΝΟΥ 10Α ΠΕΥΤΡΟΥΠΟΛΗ

ΔΗΜ ΦΑΛΗΡΕΩΣ 28 ΝΕΟ ΦΑΛΗΡΟ

Ν ΣΥΡΙΓΟΥ 47 ΛΑΥΡΕΩΤΙΚΗΣ

ΣΟΥΛΙΟΥ 58 ΑΓΙΑΣ ΠΑΡΑΣΚΕΥΗΣ

Λ ΕΙΡΗΝΗΣ 39 ΑΤΤΙΚΗ Now i've managed two split it in two columns and the results are these: ΗΡΑΚΛΕΙΔΩΝ 36 ΑΘΗΝΑ ΗΡΩΩΝ ΠΟΛΥΤΕΧΝΕΙΟΥ 23 ΑΓ.ΣΤΕΦΑΝΟΣ ΠΥΡΓΙΩΤΙΣΣΗΣ 29 ΠΕΡΙΣΤΕΡΙ ΤΡΥΠΙΑ 26 Β ΠΕΥΚΗ EYΓENΩN 5 ΠEPIΣTEPI ΡΟΔΟΠΗΣ 19 21 ΒΡΙΛΗΣΣΙΑ Α ΜΠΕΡΤΟΥ 29 ΚΕΡΑΤΣΙΝΙΟΥ ΔΡΑΠΕΤΣΩΝΑΣ ΔΕΛΗΓΙΑΝΝΗ 8 ΠΕΙΡΑΙΑΣ ΠΟΛΥΒΙΟΥ ΔΗΜΗΤΡΑΚΟΠΟΥΛΟΥ 17 ΑΘΗΝΑΙΩΝ ΚΡΙΕΖΗ 54 ΜΑΡΟΥΣΙ ΙΑΣΟΝΟΣ 2 ΠΑΛΑΙΟΥ ΦΑΛΗΡΟΥ ΣΠΟΡΓΙΛΟΥ 10 ΑΘΗΝΑ ΑΝΘΕΩΝ 4 ΑΓΙΑΣ ΠΑΡΑΣΚΕΥΗΣ ΣΕΒΑΣΤΙΑΣ 33 ΝΕΑ ΣΜΥΡΝΗ ΜΑΥΡΟΚΟΡΔΑΤΟΥ 69 ΠΕΙΡΑΙΑΣ ΚΟΜΝΗΝΩΝ ΑΡΓΟΝΑΥΤΩΝ 5 ΔΡΟΣΙΑ ΑΧΙΛΛΕΩΣ 4 ΗΡΑΚΛΕΙΟ ΤΙΜΙΟΥ ΣΤΑΥΡΟΥ 14 ΑΧΑΡΝΕΣ ΑΙΣΧΥΛΟΥ 6Α ΚΗΦΙΣΙΑ ΧΡΥΣΑΝΘΕΜΩΝ 1 ΑΘΗΝΑ ΜΠΙΖΑΝΙΟΥ 54 ΙΛΙΟΝ ΚΡΗΤΗΣ 27 ΑΛΙΜΟΣ Τ.Θ. 24042 ΑΘΗΝΑ ΜΙΑΟΥΛΗ 8 ΜΑΡΟΥΣΙ ΑΧΙΛΛΕΩΣ 4 ΗΡΑΚΛΕΙΟ ΠΑΛΑΙΩΝ ΠΑΤΡΩΝ ΓΕΡΜΑΝΟΥ 8 Β ΝΙΚΑΙΑΣ ΣΠΑΡΤΗΣ 81 ΑΘΗΝΑ ΑΛΕΞΑΝΔΡΕΙΑΣ 35 ΑΘΗΝΑ ΚΕΡΚΥΡΑΣ 50 ΠΕΤΡΟΥΠΟΛΕΩΣ ΑΓΙΑΣ ΠΑΡΑΣΚΕΥΗΣ 66 ΧΑΪΔΑΡΙΟΥ Λ. ΑΛΕΞΑΝΔΡΑΣ 213Α ΑΘΗΝΑ ΗΡΩΩΝ ΠΟΛΥΤΕΧΝΕΙΟΥ 23 ΑΓ.ΣΤΕΦΑΝΟΣ ΘΑΝΟΥ ΣΙΩΚΟΥ 3 ΑΓΙΑ ΠΑΡΑΣΚΕΥΗ ΘΙΣΒΗΣ & ΣΑΛΑΜΙΝΟΣ 05 ΑΝΩ ΛΙΟΣΙΑ ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ ΚΑΛΛΙΚΡΑΤΙΔΑ 50 ΠΕΙΡΑΙΑΣ ΚΑΛΛΙΚΡΑΤΙΔΑ 50 ΠΕΙΡΑΙΑΣ ΑΓΡΙΝΙΟΥ 41 ΓΛΥΦΑΔΑΣ ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 ΙΛΙΟΥ ΗΡΩΩΝ ΠΟΛΥΤΕΧΝΕΙΟΥ 23 ΑΓ.ΣΤΕΦΑΝΟΣ ΑΓΙΑΣ ΠΑΡΑΣΚΕΥΗΣ 66 ΧΑΪΔΑΡΙΟΥ ΚΑΝΕΛΛΟΠΟΥΛΟΥ 30 ΑΓΙΑΣ ΒΑΡΒΑΡΑΣ ΠΑΠΑΝΑΣΤΑΣΙΟΥ 84 ΑΘΗΝΑ ΜΑΚΕΔΟΝΙΑΣ 17 ΑΡΓΥΡΟΥΠΟΛΗ ΜΑΚΡΥΓΙΑΝΝΗ 113 ΑΓΙΟΣ ΔΗΜΗΤΡΙΟΣ ΘΗΝΑΙΑΣ 16 ΑΘΗΝΑΙΩΝ ΤΗΝΟΥ 12 ΑΘΗΝΑ ΚΥΠΡΙΩΝ ΗΡΩΩΝ 23 ΗΛΙΟΥΠΟΛΗ ΑΙΓΕΩΣ 7 ΒΟΥΛΑ ΣΚΟΥΦΑ 49 ΑΙΓΑΛΕΩ ΝΙΚΟΛΑΟΥ ΠΛΑΣΤΗΡΑ 84 ΝΕΑΣ ΕΡΥΘΡΑΙΑΣ ΣΩΚΡΑΤΟΥΣ 30 ΔΙΟΝΥΣΟΥ ΑΓΙΑΣ ΑΝΝΗΣ 32 ΑΓΙΟΣ ΙΩΑΝΝΗΣ ΡΕΝΤΗΣ ΣΑΠΦΟΥΣ 36 ΚΑΛΛΙΘΕΑ ΔΡΑΜΑΣ 4 ΜΕΛΙΣΣΙΑ ΑΡΓΥΡΗ ΕΦΤΑΛΙΩΤΗ 15 ΑΜΑΡΟΥΣΙΟΥ ΑΘΗΝΑΓΩΡΟΥ 13 ΑΘΗΝΑ ΔΡΑΓΟΥΜΗ ΙΩΝΟΣ 64 ΠΕΙΡΑΙΑΣ ΑΝΑΞΑΓΟΡΑ 7 ΓΕΡΑΚΑΣ ΑΚΡΟΠΟΛΕΩΣ 59 ΝΕΟ ΗΡΑΚΛΕΙΟ ΡΕΑΣ 8 ΚΑΛΛΙΘΕΑ ΚΟΙΜΗΣΕΩΣ ΘΕΟΤΟΚΟΥ 36 ΓΕΡΑΚΑ ΑΡΕΩΣ 42 ΠΑΛΑΙΟΥ ΦΑΛΗΡΟΥ ΑΓ ΙΕΡΟΘΕΟΥ 35 ΠΕΡΙΣΤΕΡΙ ΝΑΥΑΡΙΝΟΥ 6 ΧΟΛΑΡΓΟΣ ΑΛΕΞΑΝΔΡΟΥ ΠΑΝΑΓΟΥΛΗ 24 ΑΓΙΑ ΠΑΡΑΣΚΕΥΗ ΚΟΥΝΤΟΥΡΙΩΤΟΥ 42 ΧΟΛΑΡΓΟΥ ΜΥΚΗΝΩΝ 71 ΜΕΓΑΡΑ ΕΛΑΙΩΝΩΝ 23 ΠΑΛΛΗΝΗΣ ΑΝΤΩΝΙΟΥ ΦΙΞ 18 ΑΘΗΝΑ/ΠΕΥΚΗ ΕΛΕΥΘΕΡΙΑΣ 3Α ΑΓΙΟΣ ΙΩΑΝΝΗΣ ΡΕΝΤΗΣ ΑΡΕΩΣ 51 ΚΗΦΙΣΙΑ ΝΙΚΟΛΑΟΥ ΠΛΑΣΤΗΡΑ 10 ΠΕΥΚΗΣ ΣEBAΣTEIAΣ 58 N ΣMYPNH ΛΕΩΦΟΡΟΣ ΙΩΝΙΑΣ 67 ΑΘΗΝΑΙΩΝ ΣΙΦΝΟΥ 4Β ΒΑΡΗ ΚΑΠΕΤΑΝ ΛΑΧΑΝΑ 33 35 ΑΘΗΝΑ ΣΕΒΔΙΚΙΟΥ 28 ΚΡΥΟΝΕΡΙ ΘΡΑΚΗΣ 56 ΒΡΙΛΗΣΣΙΩΝ ΠΑΠΑΦΛΕΣΣΑ 16 ΙΛΙΟΝ ΠΑΛΑΙΩΝ ΠΑΤΡΩΝ ΓΕΡΜΑΝΟΥ 3 ΠΑΛΑΙΟΥ ΦΑΛΗΡΟΥ ΑΓΙΟΥ ΟΡΟΥΣ 59 ΜΑΡΟΥΣΙ , Ν.ΦΙΛΟΘΕΗ ΛΟΧΑΓΟΥ ΡΕΠΕΤΣΑ 7 ΠΕΙΡΑΙΩΣ ΜΕΓΑΛΟΧΑΡΗΣ 10 ΝΕΑΣ ΜΑΚΡΗΣ ΕΛΕΥΘΕΡΙΟΥ ΒΕΝΙΖΕΛΟΥ 45 ΚΑΜΑΤΕΡΟ AΓIAΣ ΠAPAΣKEYHΣ 45 47 ΠEIPAIAΣ ΛΟΧΑΓΟΥ ΡΕΠΕΤΣΑ 7 ΠΕΙΡΑΙΩΣ ΟΛΥΜΠΟΥ 93 ΑΝΑΒΥΣΣΟΥ ΑΥΡΑΣ 32 ΣΑΡΩΝΙΚΟΥ ΜΠΑΡΟΥΞΗ 56 ΠΕΡΙΣΤΕΡΙΟΥ ΑΡΕΩΣ 80 ΠΑΛΑΙΟΥ ΦΑΛΗΡΟΥ ΗΡΑΚΛΕΙΤΟΥ 5 ΓΛΥΦΑΔΑΣ <colgroup><col><col></colgroup><tbody> </tbody>

<colgroup><col></colgroup><tbody>
</tbody>

As you can see i'm still missing a few. Some may have two numbers with a space between them like for example : 12 14
Or some of the may have a letter with a space like 13A or 13 A.
Is there a way to correct this?
Thank you for answering

 

[manosalexo]

Update!!!

I've managed to get all the numbers now the only problem left is if after the number there is a space and only one word i want it to stay in the same column.
For example:

Aristotelous 23 A Athens
Giannitson 55 B Larissa
After using code it goes like this
Aristotelous 23 A Athens
Giannitson 55 B Larissa


The code right now looks like this:

Sub Extract_Text()    Dim sh As Worksheet, cell As Range, rng As Range, rng1 As Range
    Dim k As Double, num As Boolean, cad As String
    
    Set sh = Sheets("cases_P")
    Set rng = sh.Range("Y2", sh.Range("Y" & Rows.Count).End(xlUp))
    
    For Each cell In rng
        num = False
        cad = ""
        For k = 1 To Len(cell.Value)
            If Mid(cell.Value, k, 1) Like "[0-999]" Then
                cad = Mid(cell.Value, 1, k)
                num = True
        'sh.Cells(cell.Row, "Z").Value = WorksheetFunction.Trim(Mid(cell.Value, Len(cad) + 2))
            
            ElseIf num Then
            If Mid(cell.Value, k + 1, 1) Like " ""[0-999]" Then
            cad = Mid(cell.Value, 1, k)
            End If
            
             ElseIf num Then
            If Mid(cell.Value, k + 1, 1) Like " ""[A-Z]" Then
            cad = Mid(cell.Value, 1, k)
            End If
            
            ElseIf num Then
                
                    If Mid(cell.Value, k, 1) <> " " Then cad = Mid(cell.Value, 1, k)
                    'sh.Cells(cell.Row, "Z").Value = WorksheetFunction.Trim(Mid(cell.Value, Len(cad) + 2))
                   


                  Exit For
            Else
                cad = cell.Value
           
                 End If
                ' End If
              '  End If
            
            sh.Cells(cell.Row, "Z").Value = WorksheetFunction.Trim(Mid(cell.Value, Len(cad) + 1))
        Next
        
        sh.Cells(cell.Row, "Y").Value = cad
        
    
    Next
    
    MsgBox "End"
    
End Sub