VBA required to delimit cells with Rules applied over it.

amb2301

New member
Joined
May 18, 2020
Messages
15
Reaction score
0
Points
0
Excel Version(s)
excel 2013
Hi Friends,


i need a help on fixing an existing VBA script,


Function of Existing Script:
i have hundreds of addresses to Delimit into seperate cells as shown in the attached sample file(Address sheet.xlsm)
i have a script to delimit those addresses Available in A column to the B,C,D & E column.
COlumn A: contains full address
COlumn B: Door number
COlumn C: Direction (N,E,S,W)
COlumn D: Street Name
COlumn E: Street Type


Twist is at Directions(N,E,S,W), sometimes it comes next to Door# (or) at the end of an address.
existing script, even do that work perfectly.


Note: (NE,NW,SW,SE) should not be considered in C column.


Current Requirement:
Now some addresses comes with different scenarios,
i have highlighted in yellow colour in the attached excel(green higlighted cells are working fine with existing script).
sometimes single Numberical value also (1,2,3.4,5,6,7,8,9) comes in C column,it should be moved to the D column
by adding text like(1st,2nd,3rd,4th,5th,6th,7th,8th,9th).


Could anyone please help me to resolve this issue.


Thanks in Advance.


HTML:
Sub Demo1()    Dim V(), W(), R&, S, C%        V = Application.Trim(Range("A2", [A1].End(xlDown)))        ReDim W(1 To UBound(V), 3)    For R = 1 To UBound(V)           S = Split(V(R, 1))        If IsNumeric(S(0)) Then                W(R, 0) = S(0)            If Len(S(1)) = 1 Then                W(R, 1) = S(1):  W(R, 2) = S(2):  W(R, 3) = S(3)            ElseIf Len(S(UBound(S))) = 1 Then                W(R, 1) = S(UBound(S)):  W(R, 2) = S(1):  W(R, 3) = S(2)            Else                If UBound(S) = 3 Then W(R, 2) = S(1) & " " & S(2) Else W(R, 2) = S(1)                W(R, 3) = S(UBound(S))            End If        Else           W(R, 0) = Left(S(0), Len(S(0)) - 1):  W(R, 1) = Right(S(0), 1):  W(R, 2) = S(1): W(R, 3) = S(2)        End If    Next        [B2:E2].Resize(R - 1) = WEnd Sub
 

Attachments

  • address sheet.xlsm
    84.7 KB · Views: 7
Copy your code from your workbook, paste it in Notepad, copy from Notepad and paste here.
 
hi macropod,
i m extremely sorry for this happening (cross-posting) , i will make sure it will not happening again in the forum.
i will follow the rules hereafter
 
okay sure, i will post the links hereafter, if any cross-posting is done
 
only 2 cross postings done, that it has been shown up in this forum.....nothing else cross posted.
 
Back
Top