Line spitting with specific characteristics

manosalexo

New Member
Joined
Mar 5, 2019
Messages
8
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>
Code:
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
 
I think these are all cases:

SourceTarget 1Target 2
ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥΕΠΙΚΟΥΡΟΥ 31ΠΕΡΙΣΤΕΡΙΟΥ
ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ ΡΕΝΤΗΣΕΠΙΚΟΥΡΟΥ 31ΠΕΡΙΣΤΕΡΙΟΥ ΡΕΝΤΗΣ
ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ 18 ΡΕΝΤΗΣΕΠΙΚΟΥΡΟΥ 31ΠΕΡΙΣΤΕΡΙΟΥ 18 ΡΕΝΤΗΣ
ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π ΕΙΡΑΙΑΣΚΑΛΛΙΚΡΑΤΙΔΑ 50 ΠΕΙΡΑΙΑΣ
ΑΓΡΙΝΙΟΥ 41Γ ΛΥΦΑΔΑΣΑΓΡΙΝΙΟΥ 41ΓΛΥΦΑΔΑΣ
ΣΚΟΥΦΑ 49ΣΚΟΥΦΑ 49
ΚΑΛΛΙΚΡΑΤΙΔΑ 50 ΠΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π
ΑΓΡΙΝΙΟΥ 41ΓΑΓΡΙΝΙΟΥ 41Γ
ΤΗΝΟΥ 12 15 ΑΘΗΝΑΤΗΝΟΥ 12 15ΑΘΗΝΑ
ΤΗΝΟΥ 12 15 A ΑΘΗΝΑ ΡΕΝΤΗΣΤΗΝΟΥ 12 15 AΑΘΗΝΑ ΡΕΝΤΗΣ
ΤΗΝΟΥ 12 15A ΑΘΗΝΑΤΗΝΟΥ 12 15AΑΘΗΝΑ
ΤΗΝΟΥ 12 15ΤΗΝΟΥ 12 15
ΤΗΝΟΥ 12 15 ΑΤΗΝΟΥ 12 15 Α
ΤΗΝΟΥ 12 15ΑΤΗΝΟΥ 12 15Α
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 ΙΛΙΟΥΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34ΙΛΙΟΥ
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 A ΙΛΙΟΥΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 AΙΛΙΟΥ
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34A ΙΛΙΟΥΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34AΙΛΙΟΥ
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 ΙΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 Ι
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34ΙΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34Ι
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 ΑΘΗΝΑ/ΠΕΥΚΗΑΝΤΩΝΙΟΥ ΦΙΞ 18 16ΑΘΗΝΑ/ΠΕΥΚΗ
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 A ΑΘΗΝΑ/ΠΕΥΚΗΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 AΑΘΗΝΑ/ΠΕΥΚΗ
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16A ΑΘΗΝΑ/ΠΕΥΚΗΑΝΤΩΝΙΟΥ ΦΙΞ 18 16AΑΘΗΝΑ/ΠΕΥΚΗ
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 ΑΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 Α
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16ΑΑΝΤΩΝΙΟΥ ΦΙΞ 18 16Α

<tbody>
</tbody>
ΑΙΓΕΩΣ 7 ΒΟΥΛΑΑΙΓΕΩΣ 7ΒΟΥΛΑ
ΑΙΓΕΩΣ 7 B ΒΟΥΛΑΑΙΓΕΩΣ 7 BΒΟΥΛΑ
ΑΙΓΕΩΣ 7B ΒΟΥΛΑΑΙΓΕΩΣ 7BΒΟΥΛΑ
ΑΙΓΕΩΣ 7 1 ΒΟΥΛΑΑΙΓΕΩΣ 7 1ΒΟΥΛΑ
ΑΙΓΕΩΣ 7 1 B ΒΟΥΛΑΑΙΓΕΩΣ 7 1 BΒΟΥΛΑ
ΑΙΓΕΩΣ 7 1B ΒΟΥΛΑΑΙΓΕΩΣ 7 1BΒΟΥΛΑ

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

Try this code, the results in Z and AA columns:


Code:
Sub Extract_Text2()
    Dim sh As Worksheet, wCell As Range, rng As Range
    Dim wWords As Variant, wPal As String, cad As String
    Dim w As Double, k As Double, num As Boolean
    
    Set sh = Sheets("cases_P")
    Set rng = sh.Range("Y2", sh.Range("Y" & Rows.Count).End(xlUp))
    
    For Each wCell In rng
        num = False
        cad = ""
        wWords = Split(wCell, " ")
        For w = LBound(wWords) To UBound(wWords)
            wPal = wWords(w)
        
            If IsNumeric(wPal) Then
                'first number
                num = True
                cad = cad & wPal & " "
            Else
                If cad = "" Then
                    'first word
                    cad = cad & wPal & " "
                Else
                    'first number with letter
                    For k = 1 To Len(wPal)
                        If Mid(wPal, k, 1) Like "[0-9]" Then
                            cad = cad & wPal & " "
                            num = True
                            Exit For
                        End If
                    Next


                    If num = True Then
                        'next single letter
                        If Len(wPal) = 1 Then
                            cad = cad & wPal & " "
                        End If
                        Exit For
                    Else
                        'word without number
                        cad = cad & wPal & " "
                    End If
                End If
            End If
        Next
        cad = WorksheetFunction.Trim(cad)
        wCell.Offset(0, 1) = cad
        cad = Mid(wCell, Len(cad) + 2)
        wCell.Offset(0, 2) = cad
    Next
    
    MsgBox "End"
    
End Sub
 
Upvote 0

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
I think these are all cases:

SourceTarget 1Target 2
ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥΕΠΙΚΟΥΡΟΥ 31ΠΕΡΙΣΤΕΡΙΟΥ
ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ ΡΕΝΤΗΣΕΠΙΚΟΥΡΟΥ 31ΠΕΡΙΣΤΕΡΙΟΥ ΡΕΝΤΗΣ
ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ 18 ΡΕΝΤΗΣΕΠΙΚΟΥΡΟΥ 31ΠΕΡΙΣΤΕΡΙΟΥ 18 ΡΕΝΤΗΣ
ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π ΕΙΡΑΙΑΣΚΑΛΛΙΚΡΑΤΙΔΑ 50 ΠΕΙΡΑΙΑΣ
ΑΓΡΙΝΙΟΥ 41Γ ΛΥΦΑΔΑΣΑΓΡΙΝΙΟΥ 41ΓΛΥΦΑΔΑΣ
ΣΚΟΥΦΑ 49ΣΚΟΥΦΑ 49
ΚΑΛΛΙΚΡΑΤΙΔΑ 50 ΠΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π
ΑΓΡΙΝΙΟΥ 41ΓΑΓΡΙΝΙΟΥ 41Γ
ΤΗΝΟΥ 12 15 ΑΘΗΝΑΤΗΝΟΥ 12 15ΑΘΗΝΑ
ΤΗΝΟΥ 12 15 A ΑΘΗΝΑ ΡΕΝΤΗΣΤΗΝΟΥ 12 15 AΑΘΗΝΑ ΡΕΝΤΗΣ
ΤΗΝΟΥ 12 15A ΑΘΗΝΑΤΗΝΟΥ 12 15AΑΘΗΝΑ
ΤΗΝΟΥ 12 15ΤΗΝΟΥ 12 15
ΤΗΝΟΥ 12 15 ΑΤΗΝΟΥ 12 15 Α
ΤΗΝΟΥ 12 15ΑΤΗΝΟΥ 12 15Α
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 ΙΛΙΟΥΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34ΙΛΙΟΥ
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 A ΙΛΙΟΥΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 AΙΛΙΟΥ
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34A ΙΛΙΟΥΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34AΙΛΙΟΥ
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 ΙΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 Ι
ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34ΙΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34Ι
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 ΑΘΗΝΑ/ΠΕΥΚΗΑΝΤΩΝΙΟΥ ΦΙΞ 18 16ΑΘΗΝΑ/ΠΕΥΚΗ
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 A ΑΘΗΝΑ/ΠΕΥΚΗΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 AΑΘΗΝΑ/ΠΕΥΚΗ
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16A ΑΘΗΝΑ/ΠΕΥΚΗΑΝΤΩΝΙΟΥ ΦΙΞ 18 16AΑΘΗΝΑ/ΠΕΥΚΗ
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 ΑΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 Α
ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16ΑΑΝΤΩΝΙΟΥ ΦΙΞ 18 16Α

<tbody>
</tbody>
ΑΙΓΕΩΣ 7 ΒΟΥΛΑΑΙΓΕΩΣ 7ΒΟΥΛΑ
ΑΙΓΕΩΣ 7 B ΒΟΥΛΑΑΙΓΕΩΣ 7 BΒΟΥΛΑ
ΑΙΓΕΩΣ 7B ΒΟΥΛΑΑΙΓΕΩΣ 7BΒΟΥΛΑ
ΑΙΓΕΩΣ 7 1 ΒΟΥΛΑΑΙΓΕΩΣ 7 1ΒΟΥΛΑ
ΑΙΓΕΩΣ 7 1 B ΒΟΥΛΑΑΙΓΕΩΣ 7 1 BΒΟΥΛΑ
ΑΙΓΕΩΣ 7 1B ΒΟΥΛΑΑΙΓΕΩΣ 7 1BΒΟΥΛΑ

<tbody>
</tbody>

Try this code, the results in Z and AA columns:


Code:
Sub Extract_Text2()
    Dim sh As Worksheet, wCell As Range, rng As Range
    Dim wWords As Variant, wPal As String, cad As String
    Dim w As Double, k As Double, num As Boolean
    
    Set sh = Sheets("cases_P")
    Set rng = sh.Range("Y2", sh.Range("Y" & Rows.Count).End(xlUp))
    
    For Each wCell In rng
        num = False
        cad = ""
        wWords = Split(wCell, " ")
        For w = LBound(wWords) To UBound(wWords)
            wPal = wWords(w)
        
            If IsNumeric(wPal) Then
                'first number
                num = True
                cad = cad & wPal & " "
            Else
                If cad = "" Then
                    'first word
                    cad = cad & wPal & " "
                Else
                    'first number with letter
                    For k = 1 To Len(wPal)
                        If Mid(wPal, k, 1) Like "[0-9]" Then
                            cad = cad & wPal & " "
                            num = True
                            Exit For
                        End If
                    Next


                    If num = True Then
                        'next single letter
                        If Len(wPal) = 1 Then
                            cad = cad & wPal & " "
                        End If
                        Exit For
                    Else
                        'word without number
                        cad = cad & wPal & " "
                    End If
                End If
            End If
        Next
        cad = WorksheetFunction.Trim(cad)
        wCell.Offset(0, 1) = cad
        cad = Mid(wCell, Len(cad) + 2)
        wCell.Offset(0, 2) = cad
    Next
    
    MsgBox "End"
    
End Sub

You are a life savior!
Thank you very much for your help!
Really appreciated!
 
Upvote 0
I'm glad to help you. I appreciate your kind comments.
 
Upvote 0

Forum statistics

Threads
1,213,491
Messages
6,113,963
Members
448,536
Latest member
CantExcel123

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top