Matching text between arrays to find a related number

Hasta Manana

Hi,

There is a companion function to this which I've grown tired of editing, it's slow but at this point it finds 128 matches

Sub BGreeson(): Dim wi As Worksheet, wu As Worksheet, IOU As String, UID As String
Dim i As Long, u As Long, OU, ID, o As Long, d As Long
Set wi = Sheets("IOU"): Set wu = Sheets("UIDs")
For i = 2 To wi.Range("B" & Rows.Count).End(xlUp).Row
       
                IOU = Rep(wi.Range("B" & i))
                OU = Split(IOU, " ")
        For u = 2 To wu.Range("B" & Rows.Count).End(xlUp).Row
         
            If wu.Range("C" & u) = "*" Then GoTo GetAnother
            UID = Rep(wu.Range("B" & u))
                    ID = Split(UID, " ")
            If UBound(ID) = UBound(OU) Then
If Replace(wi.Range("B" & i), ",", "") = Replace(wu.Range("B" & u), ",", "") Then
            GoSub StampIt: GoTo GetNext: End If
            For o = LBound(OU) To UBound(OU)
            For d = LBound(ID) To UBound(ID)
            If Trim(LCase(OU(o))) = Trim(LCase(ID(d))) Then GoTo Nexto
            Next d
            GoTo GetAnother
Nexto:      Next o
            GoSub StampIt: GoTo GetNext
        End If
GetAnother: Next u
GetNext: Next i: wu.Range("C:C").ClearContents
Exit Sub
StampIt: wi.Range("K" & i) = wu.Range("A" & u): wu.Range("C" & u) = "*": Return
End Sub
Function Rep(S As String) As String
Dim Wot, Wit, i As Integer
Wot = Array("Corporation", "Company", "Limited", "Incorporated", "City of", "Capital Inc", "Electric", _
"Public", "Services", "Service", "Of", "-", "New York")
Wit = Array("Corp", "Co", "Ltd", "Inc", "", "", "Elec", "Pub", "Serv", "Serv", "", " ", "NY")
S = Replace(Replace(Trim(S), ",", ""), ".", "") 'knock off commas and periods
For i = LBound(Wot) To UBound(Wot)
S = Replace(S, Wot(i), Wit(i))
Next i
Rep = Trim(S)
End Function

I've edited the function and now with this function it gets 140:

Function Rep(S As String) As String
Dim Wot, Wit, Wff, i As Integer
Wff = Array(".", ",", "Incorporated", "Inc", "Limited", "Ltd", "Corp", "Corporation", _
"City of", "Capital Inc", "Illuminating", "Illum", "LLC", "Of")
For i = LBound(Wff) To UBound(Wff): S = Replace(S, Wff(i), ""): Next i

Wot = Array("Company", "Electric", "Public", "Services", "Service", "-", _
"New York", "&", "  ", "and", "Mount")
Wit = Array("Co", "Elec", "Pub", "Serv", "Serv", " ", "NY", " & ", " ", "&", "Mt")
For i = LBound(Wot) To UBound(Wot): S = Replace(S, Wot(i), Wit(i)): Next i

Rep = Trim(S): End Function

Here's a quick routine that gets the same 140

Function Rep(S As String) As String
Dim Wot, Wit, Wff, i As Integer
Wff = Array(".", ",", "Incorporated", "Inc", "Limited", "Ltd", "Corp", "Corporation", _
"City of", "Capital Inc", "Illuminating", "Illum", "LLC", "Of")
For i = LBound(Wff) To UBound(Wff): S = Replace(S, Wff(i), ""): Next i

Wot = Array("Company", "Electric", "Public", "Services", "Service", "-", _
"New York", "&", "  ", "and", "Mount")
Wit = Array("Co", "Elec", "Pub", "Serv", "Serv", " ", "NY", " & ", " ", "&", "Mt")
For i = LBound(Wot) To UBound(Wot): S = Replace(S, Wot(i), Wit(i)): Next i

Rep = Trim(S): End Function


Sub BGreesonQwk(): Dim wi As Worksheet, wu As Worksheet, IOU As String, UID As String
Dim i As Long, u As Long, OU, ID, o As Long, D As Long
Set wi = Sheets("IOU"): Set wu = Sheets("UIDs")

    With CreateObject("Scripting.Dictionary")
        For u = 2 To wu.Range("B" & Rows.Count).End(xlUp).Row
    UID = LCase(Rep(wu.Range("B" & u))): .Item(UID) = wu.Range("A" & u): Next u
    
    For i = 2 To wi.Range("B" & Rows.Count).End(xlUp).Row
            IOU = LCase(Rep(wi.Range("B" & i)))
    If .Exists(IOU) Then wi.Range("K" & i) = .Item(IOU)
    Next i:    End With
End Sub

* it's the same function