Excel VBA to Standardize Names in a selected range

Question

I am a complete novice at both excel as well these forums, and am attempting to piece together code that would allow a user to update a column of text entries. Basically what I was attempting to do is:

1. prompt the user to select the range

2. start from the first cell in the range and update the text based on the coding.

3. replace the text in that cell with the "clean" text

4. go to the next cell in the range do the same as #3

5. stop at end of selected range.

Sub MultiFindNReplace()
Dim InputRng As Range, ReplaceRng As Range
Dim strOld As String
Dim intPosition As Integer
Dim c As Integer
Dim CountofRows As Integer

xtitleId = "Name Update"

Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Labels to be updated ", xtitleId, InputRng.Address, Type:=8)

CountofRows = InputRng.Rows.Count
MsgBox CountofRows & " rows Selected"

For c = 1 To CountofRows

strOld = ActiveCell.Value


'Replace " .COM" with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, " .COM", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition + 4)))
    End If
Next i

'Replace ".COM" with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, ".COM", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition + 3)))
    End If
Next i

'Replace " INC." with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, " INC.", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition + 4)))
    End If
Next i

'Replace " LTD " with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, " LTD ", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & " " & Right(strOld, (Len(strOld) - (intPosition + 4)))
    End If
Next i

'Replace "INC." with a space
'For i = 1 To Len(strOld)
'    intPosition = InStr(1, strOld, ".COM", vbTextCompare)
'    If intPosition > 0 Then
'        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition + 3)))
'    End If
'Next i

'Remove trailing ", LA"
If Right(strOld, 4) = ", LA" Then strOld = Replace(strOld, ", LA", "")

'Remove trailing ",LA"
If Right(strOld, 3) = ",LA" Then strOld = Replace(strOld, ",LA", "")

'Remove "," (comma)
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, ",", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Remove trailing " LTÉE"
If Right(strOld, 5) = " LTÉE" Then strOld = Replace(strOld, " LTÉE", "")

'Remove trailing " LTÉE."
If Right(strOld, 6) = " LTÉE." Then strOld = Replace(strOld, " LTÉE.", "")

'Remove trailing " LIMITÉE"
If Right(strOld, 8) = " LIMITÉE" Then strOld = Replace(strOld, " LIMITÉE", "")

'Remove trailing " LTD."
If Right(strOld, 5) = " LTD." Then strOld = Replace(strOld, " LTD.", "")

'Remove trailing " CORP."
If Right(strOld, 6) = " CORP." Then strOld = Replace(strOld, " CORP.", "")

'Remove trailing " CO."
If Right(strOld, 4) = " CO." Then strOld = Replace(strOld, " CO.", "")

'Remove trailing " INCORPORATION"
If Right(strOld, 14) = " & CO" Then strOld = Replace(strOld, " INCORPORATION", "")

'Remove trailing " & CO"
If Right(strOld, 5) = " & CO" Then strOld = Replace(strOld, " & CO", "")

'Remove trailing " AND CO"
If Right(strOld, 7) = " AND CO" Then strOld = Replace(strOld, " AND CO", "")

'Remove trailing " & CO."
If Right(strOld, 6) = " & CO." Then strOld = Replace(strOld, " & CO.", "")

'Remove trailing " CO. LTD"
If Right(strOld, 8) = " CO. LTD" Then strOld = Replace(strOld, " CO. LTD", "")

'Remove trailing " & CO INC"
If Right(strOld, 9) = " & CO INC" Then strOld = Replace(strOld, " & CO INC", "")

'Remove trailing " & CO., INC."
If Right(strOld, 12) = " & CO., INC." Then strOld = Replace(strOld, " & CO., INC.", "")

'Remove trailing " CO., INC."
If Right(strOld, 10) = " CO., INC." Then strOld = Replace(strOld, " CO., INC.", "")

'Remove trailing " CO (INC)"
If Right(strOld, 9) = " CO (INC)" Then strOld = Replace(strOld, " CO (INC)", "")

'Replace "&" with "AND"
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, "&", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & "AND" & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Replace "-" (hyphen) with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, "-", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & " " & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Remove leading or trailing "THE"
If Left(strOld, 4) = "THE " Then strOld = Replace(strOld, "THE ", "")
If Left(strOld, 6) = "(THE) " Then strOld = Replace(strOld, "(THE) ", "")
If Right(strOld, 4) = " THE" Then strOld = Replace(strOld, " THE", "")
If Right(strOld, 6) = " (THE)" Then strOld = Replace(strOld, " (THE)", "")

'Remove leading or trailing "LE"
If Left(strOld, 3) = "LE " Then strOld = Replace(strOld, "LE ", "")
If Left(strOld, 5) = "(LE) " Then strOld = Replace(strOld, "(LE) ", "")
If Right(strOld, 4) = " LE" Then strOld = Replace(strOld, " LE", "")

'Remove leading or trailing "LES"
If Left(strOld, 4) = "LES " Then strOld = Replace(strOld, "LES ", "")
If Left(strOld, 6) = "(LES) " Then strOld = Replace(strOld, "(LES) ", "")
If Right(strOld, 4) = " LES" Then strOld = Replace(strOld, " LES", "")

'Remove leading "LA "
If Left(strOld, 3) = "LA " Then strOld = Replace(strOld, "LA ", "")
If Left(strOld, 5) = "(LA) " Then strOld = Replace(strOld, "(LA) ", "")


'Remove leading "(L') "
If Left(strOld, 5) = "(L') " Then strOld = Replace(strOld, "(L') ", "")

'Remove trailing " LTD", " INC", " SVC", " CTR", " LIMITED", " LIMITED PARTNERSHIP",
'" CO", " LT", " MD", " OD", " THE CO LTD", " LTEE", " LTEE CORP", " CORP", " INCORPORATED"
If Right(strOld, 4) = " LTD" Then strOld = Replace(strOld, " LTD", "")
If Right(strOld, 4) = " INC" Then strOld = Left(strOld, (Len(strOld) - 4))
If Right(strOld, 4) = " SVC" Then strOld = Replace(strOld, " SVC", "")
If Right(strOld, 4) = " CTR" Then strOld = Replace(strOld, " CTR", "")
If Right(strOld, 8) = " LIMITED" Then strOld = Replace(strOld, " LIMITED", "")
If Right(strOld, 20) = " LIMITED PARTNERSHIP" Then strOld = Replace(strOld, " LIMITED PARTNERSHIP", "")
If Right(strOld, 3) = " CO" Then strOld = Replace(strOld, " CO", "")
If Right(strOld, 3) = " LT" Then strOld = Replace(strOld, " LT", "")
If Right(strOld, 3) = " MD" Then strOld = Replace(strOld, " MD", "")
If Right(strOld, 3) = " OD" Then strOld = Replace(strOld, " OD", "")
If Right(strOld, 7) = " THE CO LTD" Then strOld = Replace(strOld, " THE CO LTD", "")
If Right(strOld, 5) = " LTEE" Then strOld = Replace(strOld, " LTEE", "")
If Right(strOld, 10) = " LTEE CORP" Then strOld = Replace(strOld, " LTEE CORP", "")
If Right(strOld, 5) = " CORP" Then strOld = Replace(strOld, " CORP", "")
If Right(strOld, 13) = " INCORPORATED" Then strOld = Replace(strOld, " INCORPORATED", "")

'Replace " INC " with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, " INC ", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition) & Right(strOld, (Len(strOld) - (intPosition + 4)))
    End If
Next i

'Remove "." (period)
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, ".", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Remove "'" (period)
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, "'", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Remove trailing " AND"
If Right(strOld, 4) = " AND" Then strOld = Replace(strOld, " AND", "")

Next c
MsgBox "Finished"
End Sub

Answer 1

• This code accepts a selection of one cell, up to a column of contiguous cells
• Copies the range to an array for efficiency
• Performs all replacements in your posted code in the array
• Places the updated array back on the selected range

---

Option Explicit

Public Sub MultiFindNReplace()

    Const LBLS  As String = "Labels to be updated "
    Const xNAME As String = "Name Update"

    Const OUT   As String = " .COM|.COM| INC.|INC.| INC | LTD |,|-|.|'"

    Const R1    As String = " AND|, LA|,LA| LTÉE| LTÉE.| LIMITÉE| LTD.| INCORPORATION|"
    Const R2    As String = " CORP.| CO.| & CO| AND CO| & CO.| CO. LTD| & CO INC|"
    Const R3    As String = " & CO., INC.| CO., INC.| CO (INC)| LTD| INC| SVC| CTR|"
    Const R4    As String = " LIMITED| LIMITED PARTNERSHIP| CO| LT| MD| OD| THE CO LTD|"
    Const R5    As String = " LTEE| LTEE CORP| CORP| INCORPORATED"

    Const RSIDE As String = R1 & R2 & R3 & R4 & R5

    Const L1    As String = "THE | THE|(THE) | (THE)|LE | LE|(LE) | (LE)|LES |"
    Const L2    As String = " LES|(LES) | (LES)|LA |(LA) |(L') "

    Const LSIDE As String = L1 & L2

    Dim inRng As Range, mAr As Variant, allRows As Long, i As Long, itm As Variant
    Dim outArr As Variant, rsArr As Variant, lsArr As Variant, sz1 As Long, sz2 As Long

    outArr = Split(OUT, "|")
    rsArr = Split(RSIDE, "|")
    lsArr = Split(LSIDE, "|")

    Set inRng = Application.Selection
    Set inRng = Application.InputBox(LBLS, xNAME, inRng.Address, Type:=8)

    If inRng.Columns.Count > 1 Or inRng.Areas.Count > 1 Then
        MsgBox "Please select a single (contiguous) column"
        Exit Sub
    End If

    allRows = inRng.Rows.Count
    MsgBox allRows & " rows Selected"

    If inRng.Count = 1 Then     'if only one cell selected force mAr to array
        ReDim mAr(1, 1)
        mAr(1, 1) = inRng.Value2
    Else
        mAr = inRng.Value2
    End If

    For i = 1 To allRows

       For Each itm In outArr   'remove all occurences of "itm"
         mAr(i, 1) = Replace(mAr(i, 1), itm, vbNullString, , , vbTextCompare)
       Next

       mAr(i, 1) = Replace(mAr(i, 1), "&", "AND")  'replace "&" with "AND"

       For Each itm In rsArr    'remove trailing "itm"
         sz1 = Len(itm)
         sz2 = Len(mAr(i, 1))
         If Right(mAr(i, 1), sz1) = itm Then mAr(i, 1) = Left(mAr(i, 1), sz2 - sz1)
       Next

       For Each itm In lsArr    'remove leading "itm"
         sz1 = Len(itm)
         sz2 = Len(mAr(i, 1))
         If Left(mAr(i, 1), Len(itm)) = itm Then mAr(i, 1) = Right(mAr(i, 1), sz2 - sz1)
       Next

    Next

    inRng = mAr                 'place memory array back to range
    MsgBox "Finished"

End Sub

---

Notes:

• I moved all hard coded values into constants at the top of the sub for easier maintenance

  (I think I added a couple of them - please check and remove the ones you don't need)