Find and Replace Suffix Macro

Silky0

New Member
Joined
Mar 8, 2022
Messages
6
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code:
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
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top