Array Variants of similar names

Question

I have a large list of Addresses in one cell of a spreadsheet. I am trying to split out the the Name (either Business or Residential, the Street Number the Street Names the Town/City etc. This process will take several different pieces of code and some of which I have already written and is working. The precise element that I am working on now is to identify and split out Business names. To do this I am placing the " | " delimiter value at the end of the business name. However, as you see from the code below some rows have a business name ending with "Son" "Sons" "Co." "Co. Ltd" "Ltd." and when I run the sub routine the code does not distinguish the different nuances and it will apply the delimiter more than once eg. " after Co. and after Ltd." Is there a way to modify my code to ensure the delimiter is only applied once at the end of the name. Here is a sample of cell values:

Ankers & Son confectioners  
Anning William Ltd. corn mers.  
Anniss Bros. motor car garage  
Argyle Garage & Haulage Co. motor engnr's.  
Armour & Co. Ltd. meat salesmen  
Ash & Son wine merchants  
Ashford & Son Ltd.  
Ashford Stores  
Barrett & Co. solicitors  

Just to reiterate I have used different code to separate out the street number, street name, Town/City etc. I am now trying to separate the business name from the information text. I hope this helps clarify my question.

I have also toyed with the idea of modifying this simple code :

Sub ReplaceExample()
    Dim OriginalText As String
    Dim CorrectedText As String

    OriginalText = Range("A62").Value

    CorrectedText = Replace(OriginalText, " b", " |  b")

    Range("A62").Offset(, 1).Value = CorrectedText
End Sub

This puts the delimiter at the beginning of the text that follows the business name "Co. " "Co. Ltd" etc.

Sub ReplChar2()

    Dim sh1 As Worksheet
        Set sh1 = Sheets("Sheet4")
    Dim FindOld As Variant ' Set the number of Titles in the Array
    Dim i As Integer
    Dim Rng As Range
    Dim Cell As Range

    Application.ScreenUpdating = False

    FindOld = Array("Sons", "Son", "Ltd.", "Office", "Brothers", "Charity", "School", "Bros.", "Dept.", "Agency", "Co.", "hotel", "office")
        Set Rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
            For Each Cell In Rng
                For i = LBound(FindOld) To UBound(FindOld) 'UBound function to loop through all the elements in an array.
                Cell.Replace What:=FindOld(i), Replacement:=FindOld(i) & " | ", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        Next i
    Next
    Application.ScreenUpdating = True
End Sub

Answer 1

From the example you have shown, it seems you could split the cell contents using the last capitalized word as the key. I used Regular Expressions to find the last capitalized word, but you can use a different method.

Although I would approach your problem differently, if you just want to place a delimiter after the last capitalized word in the cell, you can do this:

    Dim RE As Object
    Const sPat As String = "[A-Z]\S+(?!.*[A-Z]\w+)" 'Match last capitalized word
    Const sRepl As String = "$&|" 'inserts pipe after the match
    Dim Cell As Range
    Dim Rng As Range

Set Rng = Range(...whatever...)
Set RE = CreateObject("vbscript.regexp")
With RE
    .Pattern = sPat
    .IgnoreCase = False
    .Global = True
End With

'...
For Each Cell In Rng
    If InStr(Cell, "|") = 0 Then 'Don't do the replace more than once
        Cell = RE.Replace(Cell, sRepl) 'or Cell.Offset(…)
    End If
Next Cell

Here is the result using your original data