Line spitting with specific characteristics

M

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

[TABLE="width: 473"]
<colgroup><col></colgroup><tbody>[TR]
[TD]ΗΡΑΚΛΕΙΔΩΝ 36 ΑΘΗΝΑ 11851 ΑΤΤΙΚΗΣ[/TD]
[/TR]
[TR]
[TD]ΗΡΩΩΝ ΠΟΛΥΤΕΧΝΕΙΟΥ 23 ΑΓ.ΣΤΕΦΑΝΟΣ 14565 ΑΤΤΙΚΗΣ[/TD]
[/TR]
[TR]
[TD]ΠΥΡΓΙΩΤΙΣΣΗΣ 29 ΠΕΡΙΣΤΕΡΙ 12136 ΑΤΤΙΚΗΣ[/TD]
[/TR]
[TR]
[TD]ΤΡΥΠΙΑ 26 Β ΠΕΥΚΗ 15121 ΑΤΤΙΚΗΣ[/TD]
[/TR]
[TR]
[TD]EYΓENΩN 5 - ΠEPIΣTEPI 12134

Result:

[TABLE="width: 340"]
<colgroup><col></colgroup><tbody>[TR]
[TD]ΗΡΑΚΛΕΙΔΩΝ 36 ΑΘΗΝΑ[/TD]
[/TR]
[TR]
[TD]ΗΡΩΩΝ ΠΟΛΥΤΕΧΝΕΙΟΥ 23 ΑΓ.ΣΤΕΦΑΝΟΣ[/TD]
[/TR]
[TR]
[TD]ΠΥΡΓΙΩΤΙΣΣΗΣ 29 ΠΕΡΙΣΤΕΡΙ[/TD]
[/TR]
[TR]
[TD]ΤΡΥΠΙΑ 26 Β ΠΕΥΚΗ[/TD]
[/TR]
[TR]
[TD]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:

[/TD]
[/TR]
</tbody>[/TABLE]

[/TD]
[/TR]
</tbody>[/TABLE]
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
 
Sort by date Sort by votes
I think these are all cases:

[TABLE="class: grid, width: 652"]
<tbody>[TR]
[TD="align: center"]Source[/TD]
[TD="align: center"]Target 1[/TD]
[TD="align: center"]Target 2[/TD]
[/TR]
[TR]
[TD]ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ[/TD]
[TD]ΕΠΙΚΟΥΡΟΥ 31[/TD]
[TD]ΠΕΡΙΣΤΕΡΙΟΥ[/TD]
[/TR]
[TR]
[TD]ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ ΡΕΝΤΗΣ[/TD]
[TD]ΕΠΙΚΟΥΡΟΥ 31[/TD]
[TD]ΠΕΡΙΣΤΕΡΙΟΥ ΡΕΝΤΗΣ[/TD]
[/TR]
[TR]
[TD]ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ 18 ΡΕΝΤΗΣ[/TD]
[TD]ΕΠΙΚΟΥΡΟΥ 31[/TD]
[TD]ΠΕΡΙΣΤΕΡΙΟΥ 18 ΡΕΝΤΗΣ[/TD]
[/TR]
[TR]
[TD]ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π ΕΙΡΑΙΑΣ[/TD]
[TD]ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π[/TD]
[TD]ΕΙΡΑΙΑΣ[/TD]
[/TR]
[TR]
[TD]ΑΓΡΙΝΙΟΥ 41Γ ΛΥΦΑΔΑΣ[/TD]
[TD]ΑΓΡΙΝΙΟΥ 41Γ[/TD]
[TD]ΛΥΦΑΔΑΣ[/TD]
[/TR]
[TR]
[TD]ΣΚΟΥΦΑ 49[/TD]
[TD]ΣΚΟΥΦΑ 49[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π[/TD]
[TD]ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΑΓΡΙΝΙΟΥ 41Γ[/TD]
[TD]ΑΓΡΙΝΙΟΥ 41Γ[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15 ΑΘΗΝΑ[/TD]
[TD]ΤΗΝΟΥ 12 15[/TD]
[TD]ΑΘΗΝΑ[/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15 A ΑΘΗΝΑ ΡΕΝΤΗΣ[/TD]
[TD]ΤΗΝΟΥ 12 15 A[/TD]
[TD]ΑΘΗΝΑ ΡΕΝΤΗΣ[/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15A ΑΘΗΝΑ[/TD]
[TD]ΤΗΝΟΥ 12 15A[/TD]
[TD]ΑΘΗΝΑ[/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15[/TD]
[TD]ΤΗΝΟΥ 12 15[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15 Α[/TD]
[TD]ΤΗΝΟΥ 12 15 Α[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15Α[/TD]
[TD]ΤΗΝΟΥ 12 15Α[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 ΙΛΙΟΥ[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34[/TD]
[TD]ΙΛΙΟΥ[/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 A ΙΛΙΟΥ[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 A[/TD]
[TD]ΙΛΙΟΥ[/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34A ΙΛΙΟΥ[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34A[/TD]
[TD]ΙΛΙΟΥ[/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 Ι[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 Ι[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34Ι[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34Ι[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16[/TD]
[TD]ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 A ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 A[/TD]
[TD]ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16A ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16A[/TD]
[TD]ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 Α[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 Α[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16Α[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16Α[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="class: grid, width: 652"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]ΑΙΓΕΩΣ 7 ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7 B ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7 B[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7B ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7B[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7 1 ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7 1[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7 1 B ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7 1 B[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7 1B ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7 1B[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
</tbody>[/TABLE]

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

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
DanteAmor said:
I think these are all cases:

[TABLE="class: grid, width: 652"]
<tbody>[TR]
[TD="align: center"]Source[/TD]
[TD="align: center"]Target 1[/TD]
[TD="align: center"]Target 2[/TD]
[/TR]
[TR]
[TD]ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ[/TD]
[TD]ΕΠΙΚΟΥΡΟΥ 31[/TD]
[TD]ΠΕΡΙΣΤΕΡΙΟΥ[/TD]
[/TR]
[TR]
[TD]ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ ΡΕΝΤΗΣ[/TD]
[TD]ΕΠΙΚΟΥΡΟΥ 31[/TD]
[TD]ΠΕΡΙΣΤΕΡΙΟΥ ΡΕΝΤΗΣ[/TD]
[/TR]
[TR]
[TD]ΕΠΙΚΟΥΡΟΥ 31 ΠΕΡΙΣΤΕΡΙΟΥ 18 ΡΕΝΤΗΣ[/TD]
[TD]ΕΠΙΚΟΥΡΟΥ 31[/TD]
[TD]ΠΕΡΙΣΤΕΡΙΟΥ 18 ΡΕΝΤΗΣ[/TD]
[/TR]
[TR]
[TD]ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π ΕΙΡΑΙΑΣ[/TD]
[TD]ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π[/TD]
[TD]ΕΙΡΑΙΑΣ[/TD]
[/TR]
[TR]
[TD]ΑΓΡΙΝΙΟΥ 41Γ ΛΥΦΑΔΑΣ[/TD]
[TD]ΑΓΡΙΝΙΟΥ 41Γ[/TD]
[TD]ΛΥΦΑΔΑΣ[/TD]
[/TR]
[TR]
[TD]ΣΚΟΥΦΑ 49[/TD]
[TD]ΣΚΟΥΦΑ 49[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π[/TD]
[TD]ΚΑΛΛΙΚΡΑΤΙΔΑ 50 Π[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΑΓΡΙΝΙΟΥ 41Γ[/TD]
[TD]ΑΓΡΙΝΙΟΥ 41Γ[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15 ΑΘΗΝΑ[/TD]
[TD]ΤΗΝΟΥ 12 15[/TD]
[TD]ΑΘΗΝΑ[/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15 A ΑΘΗΝΑ ΡΕΝΤΗΣ[/TD]
[TD]ΤΗΝΟΥ 12 15 A[/TD]
[TD]ΑΘΗΝΑ ΡΕΝΤΗΣ[/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15A ΑΘΗΝΑ[/TD]
[TD]ΤΗΝΟΥ 12 15A[/TD]
[TD]ΑΘΗΝΑ[/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15[/TD]
[TD]ΤΗΝΟΥ 12 15[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15 Α[/TD]
[TD]ΤΗΝΟΥ 12 15 Α[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΤΗΝΟΥ 12 15Α[/TD]
[TD]ΤΗΝΟΥ 12 15Α[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 ΙΛΙΟΥ[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34[/TD]
[TD]ΙΛΙΟΥ[/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 A ΙΛΙΟΥ[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 A[/TD]
[TD]ΙΛΙΟΥ[/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34A ΙΛΙΟΥ[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34A[/TD]
[TD]ΙΛΙΟΥ[/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 Ι[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34 Ι[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34Ι[/TD]
[TD]ΛΑΜΠΡΟΥ ΚΑΤΣΩΝΗ 34Ι[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16[/TD]
[TD]ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 A ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 A[/TD]
[TD]ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16A ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16A[/TD]
[TD]ΑΘΗΝΑ/ΠΕΥΚΗ[/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 Α[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16 Α[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16Α[/TD]
[TD]ΑΝΤΩΝΙΟΥ ΦΙΞ 18 16Α[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="class: grid, width: 652"]
<tbody>[TR]
[TD]ΑΙΓΕΩΣ 7 ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7 B ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7 B[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7B ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7B[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7 1 ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7 1[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7 1 B ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7 1 B[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
[TR]
[TD]ΑΙΓΕΩΣ 7 1B ΒΟΥΛΑ[/TD]
[TD]ΑΙΓΕΩΣ 7 1B[/TD]
[TD]ΒΟΥΛΑ[/TD]
[/TR]
</tbody>[/TABLE]

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
Click to expand...

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
You must log in or register to reply here.

Similar threads

J
  • Question Question
Runtime error on code 1072896658 (c00ce56e)
Replies
5
Views
1K
jamescooper
J
A
  • Question Question
Need to remove blank lines
Replies
6
Views
1K
Avogadro
A
A
  • Question Question
Form Automation: Populating a ComboBox during a dynamic userform build
2
Replies
12
Views
2K
Atroxell
A
M
  • Question Question
Modify VBA code to input value to specific column
Replies
2
Views
1K
AFPathfinder
A
A
  • Question Question
Adding A Page Break To A Specific and Dynamic Point in A Worksheet
Replies
0
Views
465
Ark68
A

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

Share this page

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