相似名称的数组变体

Question

我在电子表格的一个单元格中有大量地址。我正在尝试拆分名称（公司名称或住宅名称，街道编号，街道名称称为城镇/城市等）。此过程将使用几段不同的代码，其中一些代码已经编写并且正在运行。我现在正在处理的元素是识别并拆分业务名称。为此，我将“ |”定界符值放在业务名称的末尾。但是，正如您从下面的代码中看到的，有些行中有一个业务以“ Son”，“ Sons”，“ Co。”，“ Co。Ltd”，“ Ltd。”结尾的名称，当我运行子例程时，代码不会区分不同的细微差别，并且它将多次使用定界符，例如。 Co. and after Ltd.”是否可以修改我的代码，以确保定界符仅在名称末尾应用一次。 这是单元格值的示例：

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  

仅重申一下，我使用了不同的代码来区分街道编号，街道名称，城镇/城市等。我现在尝试将公司名称与信息文本区分开。我希望这有助于澄清我的问题。

我也很想修改这个简单的代码：

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

这会将分隔符放在公司名称“ Co。”，“ Co。Ltd”等后面的文本的开头。

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

从显示的示例中，您似乎可以使用最后一个大写单词作为键来拆分单元格内容。我使用正则表达式来查找最后一个大写的单词，但是您可以使用其他方法。

尽管我会以不同的方式处理您的问题，但是，如果您只想在单元格中最后一个大写的单词之后放置一个定界符，您可以这样做：

    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

这是使用原始数据的结果