Find and Replace Suffix Macro

[Silky0]

All,

I am trying to remove common company suffix names from a large dataset and the code I have below works to an extent but I am hoping to get some help to clean up the code and make it a little bit more user friendly.

I am hoping to replace the s1 array with a defined table (on Suffix tab called SuffixList) and as you can see there is multiple instances of same suffix due to commas, periods, or spaces. If there is a way to catch those so we dont have to list multiple versions of the same suffix, that would be greatly appreciated.

Sub Remove_Suffix()

    Application.ScreenUpdating = False
    Dim cel As Range
    Dim nameRange As Range
    Set nameRange = Sheets("Data").Range("C16:C1015")
    
    Dim s1 As Variant
    s1 = Array(" AB", " AS", " AG", " BV", " OP", " NV", " Plc", " SA", " SNC", ", NA", " NA", " SAS", " SpA", " Pty", " A/S", " SGIIC", " UA", " SGR", ", LLLP.", ", LLLP", " LLLP.", " LLLP", ", LLP.", ", LLP", " LLP.", " LLP", ", LP.", ", LP", ", L.P.", " LP.", " LP", " SA", " GmbH", "mbH", ", LLC", " LLC", " Corp.", ", Ltd.", ", Ltd", " Ltd.", " Ltd.", " MDTA", ", FSB", " FSB", " DAC", " ULC", " Ltda.", "LTD", ", LTD", ", INC.", ", INC.+", ",LLC+", ", L.L.C")
    
    Dim lenName As Integer
    Dim lenSuffix As Integer
    Dim rightEnd As String
    
    
    For Each cel In nameRange
        lenName = Len(cel)
        
        ' if statement to remove "()" that end a company name
        lenSuffix = Len(") ")
        rightEnd = Right(cel, lenSuffix)
        If InStr(rightEnd, ")") Then
            cel = Left(cel, InStr(cel, "(") - 2)
        End If
        
        For Each Suffix In s1
            lenSuffix = Len(Suffix)
            rightEnd = Right(cel, lenSuffix)
            If InStr(rightEnd, Suffix) Then
                cel.Replace What:=Suffix, Replacement:=""
                Exit For
            End If
        Next Suffix
        
    Next cel

End Sub