Hi,
I have written a macro designed to scrub an organization's name so I can
better match/compare its value. However, this macro takes 5 to 10 minutes to
process on over 1000 records (where the org name is just in one column).

I am using the Select Case method to pull out the last word to check and
remove certain common words. This seems to take the longest. Is there a
better way to write the macro?

Macro is below (Excel 2007):

Sub Scrub_Org_Name()

Dim sName1 As String
Dim sName2 As String
Dim iName2 As Integer
Dim sLessSpaces As String
Dim iLessSpaces As Integer
Dim sLastword As String
Dim iLast As Integer
Dim sLast As String
Dim iLastRow As Long
Dim iRowCount As Long
Dim sNameCol As String
Dim Result As String
Dim iReady As Integer

iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
iRowCount = 2

sNameCol = InputBox("Enter Column Letter for Organization Name.",
"Organization Name Column", "Q")

'copy column for Organization Name to Column A
Columns(sNameCol).Select
Selection.Copy
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
ActiveCell.FormulaR1C1 = "Initial Scrub"

'Insert ScrubName Column
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
ActiveCell.FormulaR1C1 = "Scrubbed Org Name" & Chr(10) & "(Keywords
removed)"

'PERFORM INITIAL SCRUB
'__________________________________________________________________

'Find all periods and commas and "the"'s and other words that can be removed
entirely from names and remove from column B
Columns("B:B").Select
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="The ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="Incorporated", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="GMBH", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="Corporation", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="Limited", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="LTD", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="LLC", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="LLP", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="Industries", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="Univ ", Replacement:="University ",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="-", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


'PERFORM SECONDARY SCRUB (this Do/Loop method takes much longer than inital
scrub,
' therefore, if you can perform a scrub against the
whole
' name, without worrying about multple instances,
then
' perform the desired scrub using the initial scrub
' method of Search/Replace)
'____________________________________________________________________


'Run through all rows of data and trim leading and trailing spaces, plus
scrub out key words.
Do While iLastRow >= iRowCount
sName1 = Range("B" & iRowCount).Value
sName2 = UCase(Trim(sName1))
iName2 = Len(sName2)
sLessSpaces = Application.WorksheetFunction.Substitute(sName2, " ", "")
iLessSpaces = Len(sLessSpaces)


'Test for multiple words in company name
If (iName2 - iLessSpaces) = 0 Then

'If none found then then leave as is
Result = sName2

Else

'Converts the last space in a company name to a "^".
'The instance of the last space is defined by the the diff between iName2
and iLessSpaces
'(which is the length of name with spaces, less the length of name without
spaces)
sLast = Application.WorksheetFunction.Substitute(sName2, " ", "^",
iName2 - iLessSpaces)
iLast = Application.WorksheetFunction.Find("^", sLast) + 1

'Lastword is equal to the word starting at the position of the "^" above +1
sLastword = UCase(Mid(sLast, iLast, 256))

'Search for each of these types of last words below and delete them off of
the trimmed name, also make the result uppercase.
'The amount of positions to delete at the end is equal to the length of
characters plus 1 for the space before the last word.
'This approach will only delete the word if it is the last word in the name,
unlike the search and replace all approach above created by the initial scrub.
Select Case (sLastword)

Case "INC"
Result = Left(sName2, iName2 - 4)

Case "USA"
Result = Left(sName2, iName2 - 4)

Case "INTERNATIONAL"
Result = Left(sName2, iName2 - 14)

Case "PC"
Result = Left(sName2, iName2 - 3)

Case "APPLIANCES"
Result = Left(sName2, iName2 - 12)

Case "SUPPLIES"
Result = Left(sName2, iName2 - 9)

Case "SUPPLY"
Result = Left(sName2, iName2 - 7)

Case "COMPANY"
Result = Left(sName2, iName2 - 8)

Case "CORP"
Result = Left(sName2, iName2 - 5)

Case "CO"
Result = Left(sName2, iName2 - 3)

Case "IGT"
Result = Left(sName2, iName2 - 4)

Case "SERVICES"
Result = Left(sName2, iName2 - 10)

Case "SERVICES"
Result = Left(sName2, iName2 - 9)

Case "TECHNOLOGIES"
Result = Left(sName2, iName2 - 13)

Case "IND"
Result = Left(sName2, iName2 - 4)


Case Else
Result = sName2

End Select

End If

'Paste scrubbed results to Column A
Range("A" & iRowCount) = Result

'set next row to be evaluated
iRowCount = iRowCount + 1
Loop

'Delete the Initial Scrub Column and only leave the results for the
Secondary Scrub
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

End Sub

First try this:

Sub main()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Call Scurb_Org_Name
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
--
Gary''s Student - gsnu200856


"Liz" wrote:

> Hi,
> I have written a macro designed to scrub an organization's name so I can
> better match/compare its value. However, this macro takes 5 to 10 minutes to
> process on over 1000 records (where the org name is just in one column).
>
> I am using the Select Case method to pull out the last word to check and
> remove certain common words. This seems to take the longest. Is there a
> better way to write the macro?
>
> Macro is below (Excel 2007):
>
> Sub Scrub_Org_Name()
>
> Dim sName1 As String
> Dim sName2 As String
> Dim iName2 As Integer
> Dim sLessSpaces As String
> Dim iLessSpaces As Integer
> Dim sLastword As String
> Dim iLast As Integer
> Dim sLast As String
> Dim iLastRow As Long
> Dim iRowCount As Long
> Dim sNameCol As String
> Dim Result As String
> Dim iReady As Integer
>
> iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
> iRowCount = 2
>
> sNameCol = InputBox("Enter Column Letter for Organization Name.",
> "Organization Name Column", "Q")
>
> 'copy column for Organization Name to Column A
> Columns(sNameCol).Select
> Selection.Copy
> Columns("A:A").Select
> Selection.Insert Shift:=xlToRight
> Range("A1").Select
> ActiveCell.FormulaR1C1 = "Initial Scrub"
>
> 'Insert ScrubName Column
> Columns("A:A").Select
> Selection.Insert Shift:=xlToRight
> Range("A1").Select
> ActiveCell.FormulaR1C1 = "Scrubbed Org Name" & Chr(10) & "(Keywords
> removed)"
>
> 'PERFORM INITIAL SCRUB
> '__________________________________________________________________
>
> 'Find all periods and commas and "the"'s and other words that can be removed
> entirely from names and remove from column B
> Columns("B:B").Select
> Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
> Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
> Selection.Replace What:="The ", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Incorporated", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="GMBH", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Corporation", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Limited", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="LTD", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="LLC", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="LLP", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Industries", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Univ ", Replacement:="University ",
> LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="-", Replacement:=" ", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
>
> 'PERFORM SECONDARY SCRUB (this Do/Loop method takes much longer than inital
> scrub,
> ' therefore, if you can perform a scrub against the
> whole
> ' name, without worrying about multple instances,
> then
> ' perform the desired scrub using the initial scrub
> ' method of Search/Replace)
> '____________________________________________________________________
>
>
> 'Run through all rows of data and trim leading and trailing spaces, plus
> scrub out key words.
> Do While iLastRow >= iRowCount
> sName1 = Range("B" & iRowCount).Value
> sName2 = UCase(Trim(sName1))
> iName2 = Len(sName2)
> sLessSpaces = Application.WorksheetFunction.Substitute(sName2, " ", "")
> iLessSpaces = Len(sLessSpaces)
>
>
> 'Test for multiple words in company name
> If (iName2 - iLessSpaces) = 0 Then
>
> 'If none found then then leave as is
> Result = sName2
>
> Else
>
> 'Converts the last space in a company name to a "^".
> 'The instance of the last space is defined by the the diff between iName2
> and iLessSpaces
> '(which is the length of name with spaces, less the length of name without
> spaces)
> sLast = Application.WorksheetFunction.Substitute(sName2, " ", "^",
> iName2 - iLessSpaces)
> iLast = Application.WorksheetFunction.Find("^", sLast) + 1
>
> 'Lastword is equal to the word starting at the position of the "^" above +1
> sLastword = UCase(Mid(sLast, iLast, 256))
>
> 'Search for each of these types of last words below and delete them off of
> the trimmed name, also make the result uppercase.
> 'The amount of positions to delete at the end is equal to the length of
> characters plus 1 for the space before the last word.
> 'This approach will only delete the word if it is the last word in the name,
> unlike the search and replace all approach above created by the initial scrub.
> Select Case (sLastword)
>
> Case "INC"
> Result = Left(sName2, iName2 - 4)
>
> Case "USA"
> Result = Left(sName2, iName2 - 4)
>
> Case "INTERNATIONAL"
> Result = Left(sName2, iName2 - 14)
>
> Case "PC"
> Result = Left(sName2, iName2 - 3)
>
> Case "APPLIANCES"
> Result = Left(sName2, iName2 - 12)
>
> Case "SUPPLIES"
> Result = Left(sName2, iName2 - 9)
>
> Case "SUPPLY"
> Result = Left(sName2, iName2 - 7)
>
> Case "COMPANY"
> Result = Left(sName2, iName2 - 8)
>
> Case "CORP"
> Result = Left(sName2, iName2 - 5)
>
> Case "CO"
> Result = Left(sName2, iName2 - 3)
>
> Case "IGT"
> Result = Left(sName2, iName2 - 4)
>
> Case "SERVICES"
> Result = Left(sName2, iName2 - 10)
>
> Case "SERVICES"
> Result = Left(sName2, iName2 - 9)
>
> Case "TECHNOLOGIES"
> Result = Left(sName2, iName2 - 13)
>
> Case "IND"
> Result = Left(sName2, iName2 - 4)
>
>
> Case Else
> Result = sName2
>
> End Select
>
> End If
>
> 'Paste scrubbed results to Column A
> Range("A" & iRowCount) = Result
>
> 'set next row to be evaluated
> iRowCount = iRowCount + 1
> Loop
>
> 'Delete the Initial Scrub Column and only leave the results for the
> Secondary Scrub
> Columns("B:B").Select
> Selection.Delete Shift:=xlToLeft
>
> End Sub
>

I think the following code does what your posted code does, but it uses mostly built-in VB commands rather than continually reaching out for the worksheet functions. As such, I believe it will be faster than your current code. Make sure you test it out on a copy of your actual worksheet as VB code cannot be undone by Excel's Undo command.

Sub Scrub_Org_Name()
Dim X As Long
Dim LastRow As Long
Dim StartRow As Long
Dim sNameCol As String
Dim CellContents As String
Dim IndividualCellText() As String
StartRow = 2
sNameCol = InputBox("Enter Column Letter for Organization Name.", "Organization Name Column", "Q")
LastRow = Cells(Rows.Count, sNameCol).End(xlUp).Row
CellContents = Join(WorksheetFunction.Transpose(Range(sNameCol & "2:" & sNameCol & LastRow)), Chr(1))
CellContents = Replace(CellContents, ".", "")
CellContents = Replace(CellContents, ",", "")
CellContents = Replace(CellContents, "The ", "", , , vbTextCompare)
CellContents = Replace(CellContents, "Incorporated", "", , , vbTextCompare)
CellContents = Replace(CellContents, "GMBH", "", , , vbTextCompare)
CellContents = Replace(CellContents, "Corporation", "", , , vbTextCompare)
CellContents = Replace(CellContents, "Limited", "", , , vbTextCompare)
CellContents = Replace(CellContents, "LTD", "", , , vbTextCompare)
CellContents = Replace(CellContents, "LLC", "", , , vbTextCompare)
CellContents = Replace(CellContents, "LLP", "", , , vbTextCompare)
CellContents = Replace(CellContents, "Industries", "")
CellContents = Replace(CellContents, "Univ", "University", , , vbTextCompare)
CellContents = Replace(CellContents, "-", " ")
CellContents = WorksheetFunction.Trim(CellContents)
CellContents = Replace(CellContents, " " & Chr(1), Chr(1))
CellContents = Replace(CellContents, " INC" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " USA" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " INTERNATIONAL" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " PC" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " APPLIANCES" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " SUPPLIES" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " SUPPLY" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " COMPANY" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " CORP" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " CO" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " IGT" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " SERVICES" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " SERVICES" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " TECHNOLOGIES" & Chr(1), Chr(1), , , vbTextCompare)
CellContents = Replace(CellContents, " IND" & Chr(1), Chr(1), , , vbTextCompare)
IndividualCellText = Split(CellContents, Chr(1))
Application.ScreenUpdating = False
Application.Calculation = xlManual
Columns("A").Insert Shift:=xlToRight
Range("A1").Value = "Scrubbed Org Name" & vbLf & "(Keywords removed)"
For X = StartRow To LastRow
Cells(X, "A").Value = IndividualCellText(X - StartRow)
Next
Columns("A").AutoFit
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

--
Rick (MVP - Excel)


"Liz" <(E-Mail Removed)> wrote in message news:2EC5649D-35F2-4D4C-961F-(E-Mail Removed)...
> Hi,
> I have written a macro designed to scrub an organization's name so I can
> better match/compare its value. However, this macro takes 5 to 10 minutes to
> process on over 1000 records (where the org name is just in one column).
>
> I am using the Select Case method to pull out the last word to check and
> remove certain common words. This seems to take the longest. Is there a
> better way to write the macro?
>
> Macro is below (Excel 2007):
>
> Sub Scrub_Org_Name()
>
> Dim sName1 As String
> Dim sName2 As String
> Dim iName2 As Integer
> Dim sLessSpaces As String
> Dim iLessSpaces As Integer
> Dim sLastword As String
> Dim iLast As Integer
> Dim sLast As String
> Dim iLastRow As Long
> Dim iRowCount As Long
> Dim sNameCol As String
> Dim Result As String
> Dim iReady As Integer
>
> iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
> iRowCount = 2
>
> sNameCol = InputBox("Enter Column Letter for Organization Name.",
> "Organization Name Column", "Q")
>
> 'copy column for Organization Name to Column A
> Columns(sNameCol).Select
> Selection.Copy
> Columns("A:A").Select
> Selection.Insert Shift:=xlToRight
> Range("A1").Select
> ActiveCell.FormulaR1C1 = "Initial Scrub"
>
> 'Insert ScrubName Column
> Columns("A:A").Select
> Selection.Insert Shift:=xlToRight
> Range("A1").Select
> ActiveCell.FormulaR1C1 = "Scrubbed Org Name" & Chr(10) & "(Keywords
> removed)"
>
> 'PERFORM INITIAL SCRUB
> '__________________________________________________________________
>
> 'Find all periods and commas and "the"'s and other words that can be removed
> entirely from names and remove from column B
> Columns("B:B").Select
> Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
> Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
> Selection.Replace What:="The ", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Incorporated", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="GMBH", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Corporation", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Limited", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="LTD", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="LLC", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="LLP", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Industries", Replacement:="", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="Univ ", Replacement:="University ",
> LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
> Selection.Replace What:="-", Replacement:=" ", LookAt:=xlPart, _
> SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> ReplaceFormat:=False
>
>
> 'PERFORM SECONDARY SCRUB (this Do/Loop method takes much longer than inital
> scrub,
> ' therefore, if you can perform a scrub against the
> whole
> ' name, without worrying about multple instances,
> then
> ' perform the desired scrub using the initial scrub
> ' method of Search/Replace)
> '____________________________________________________________________
>
>
> 'Run through all rows of data and trim leading and trailing spaces, plus
> scrub out key words.
> Do While iLastRow >= iRowCount
> sName1 = Range("B" & iRowCount).Value
> sName2 = UCase(Trim(sName1))
> iName2 = Len(sName2)
> sLessSpaces = Application.WorksheetFunction.Substitute(sName2, " ", "")
> iLessSpaces = Len(sLessSpaces)
>
>
> 'Test for multiple words in company name
> If (iName2 - iLessSpaces) = 0 Then
>
> 'If none found then then leave as is
> Result = sName2
>
> Else
>
> 'Converts the last space in a company name to a "^".
> 'The instance of the last space is defined by the the diff between iName2
> and iLessSpaces
> '(which is the length of name with spaces, less the length of name without
> spaces)
> sLast = Application.WorksheetFunction.Substitute(sName2, " ", "^",
> iName2 - iLessSpaces)
> iLast = Application.WorksheetFunction.Find("^", sLast) + 1
>
> 'Lastword is equal to the word starting at the position of the "^" above +1
> sLastword = UCase(Mid(sLast, iLast, 256))
>
> 'Search for each of these types of last words below and delete them off of
> the trimmed name, also make the result uppercase.
> 'The amount of positions to delete at the end is equal to the length of
> characters plus 1 for the space before the last word.
> 'This approach will only delete the word if it is the last word in the name,
> unlike the search and replace all approach above created by the initial scrub.
> Select Case (sLastword)
>
> Case "INC"
> Result = Left(sName2, iName2 - 4)
>
> Case "USA"
> Result = Left(sName2, iName2 - 4)
>
> Case "INTERNATIONAL"
> Result = Left(sName2, iName2 - 14)
>
> Case "PC"
> Result = Left(sName2, iName2 - 3)
>
> Case "APPLIANCES"
> Result = Left(sName2, iName2 - 12)
>
> Case "SUPPLIES"
> Result = Left(sName2, iName2 - 9)
>
> Case "SUPPLY"
> Result = Left(sName2, iName2 - 7)
>
> Case "COMPANY"
> Result = Left(sName2, iName2 - 8)
>
> Case "CORP"
> Result = Left(sName2, iName2 - 5)
>
> Case "CO"
> Result = Left(sName2, iName2 - 3)
>
> Case "IGT"
> Result = Left(sName2, iName2 - 4)
>
> Case "SERVICES"
> Result = Left(sName2, iName2 - 10)
>
> Case "SERVICES"
> Result = Left(sName2, iName2 - 9)
>
> Case "TECHNOLOGIES"
> Result = Left(sName2, iName2 - 13)
>
> Case "IND"
> Result = Left(sName2, iName2 - 4)
>
>
> Case Else
> Result = sName2
>
> End Select
>
> End If
>
> 'Paste scrubbed results to Column A
> Range("A" & iRowCount) = Result
>
> 'set next row to be evaluated
> iRowCount = iRowCount + 1
> Loop
>
> 'Delete the Initial Scrub Column and only leave the results for the
> Secondary Scrub
> Columns("B:B").Select
> Selection.Delete Shift:=xlToLeft
>
> End Sub
>

Hi Rick -
This works flawlessly! It appears very clean as well. Can you give me a
brief explanation on how it works. I have not used this type of coding before.

Thanks much!
Liz

"Rick Rothstein" wrote:

> I think the following code does what your posted code does, but it uses mostly built-in VB commands rather than continually reaching out for the worksheet functions. As such, I believe it will be faster than your current code. Make sure you test it out on a copy of your actual worksheet as VB code cannot be undone by Excel's Undo command.
>
> Sub Scrub_Org_Name()
> Dim X As Long
> Dim LastRow As Long
> Dim StartRow As Long
> Dim sNameCol As String
> Dim CellContents As String
> Dim IndividualCellText() As String
> StartRow = 2
> sNameCol = InputBox("Enter Column Letter for Organization Name.", "Organization Name Column", "Q")
> LastRow = Cells(Rows.Count, sNameCol).End(xlUp).Row
> CellContents = Join(WorksheetFunction.Transpose(Range(sNameCol & "2:" & sNameCol & LastRow)), Chr(1))
> CellContents = Replace(CellContents, ".", "")
> CellContents = Replace(CellContents, ",", "")
> CellContents = Replace(CellContents, "The ", "", , , vbTextCompare)
> CellContents = Replace(CellContents, "Incorporated", "", , , vbTextCompare)
> CellContents = Replace(CellContents, "GMBH", "", , , vbTextCompare)
> CellContents = Replace(CellContents, "Corporation", "", , , vbTextCompare)
> CellContents = Replace(CellContents, "Limited", "", , , vbTextCompare)
> CellContents = Replace(CellContents, "LTD", "", , , vbTextCompare)
> CellContents = Replace(CellContents, "LLC", "", , , vbTextCompare)
> CellContents = Replace(CellContents, "LLP", "", , , vbTextCompare)
> CellContents = Replace(CellContents, "Industries", "")
> CellContents = Replace(CellContents, "Univ", "University", , , vbTextCompare)
> CellContents = Replace(CellContents, "-", " ")
> CellContents = WorksheetFunction.Trim(CellContents)
> CellContents = Replace(CellContents, " " & Chr(1), Chr(1))
> CellContents = Replace(CellContents, " INC" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " USA" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " INTERNATIONAL" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " PC" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " APPLIANCES" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " SUPPLIES" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " SUPPLY" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " COMPANY" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " CORP" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " CO" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " IGT" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " SERVICES" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " SERVICES" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " TECHNOLOGIES" & Chr(1), Chr(1), , , vbTextCompare)
> CellContents = Replace(CellContents, " IND" & Chr(1), Chr(1), , , vbTextCompare)
> IndividualCellText = Split(CellContents, Chr(1))
> Application.ScreenUpdating = False
> Application.Calculation = xlManual
> Columns("A").Insert Shift:=xlToRight
> Range("A1").Value = "Scrubbed Org Name" & vbLf & "(Keywords removed)"
> For X = StartRow To LastRow
> Cells(X, "A").Value = IndividualCellText(X - StartRow)
> Next
> Columns("A").AutoFit
> Application.Calculation = xlAutomatic
> Application.ScreenUpdating = True
> End Sub
>
> --
> Rick (MVP - Excel)
>
>
> "Liz" <(E-Mail Removed)> wrote in message news:2EC5649D-35F2-4D4C-961F-(E-Mail Removed)...
> > Hi,
> > I have written a macro designed to scrub an organization's name so I can
> > better match/compare its value. However, this macro takes 5 to 10 minutes to
> > process on over 1000 records (where the org name is just in one column).
> >
> > I am using the Select Case method to pull out the last word to check and
> > remove certain common words. This seems to take the longest. Is there a
> > better way to write the macro?
> >
> > Macro is below (Excel 2007):
> >
> > Sub Scrub_Org_Name()
> >
> > Dim sName1 As String
> > Dim sName2 As String
> > Dim iName2 As Integer
> > Dim sLessSpaces As String
> > Dim iLessSpaces As Integer
> > Dim sLastword As String
> > Dim iLast As Integer
> > Dim sLast As String
> > Dim iLastRow As Long
> > Dim iRowCount As Long
> > Dim sNameCol As String
> > Dim Result As String
> > Dim iReady As Integer
> >
> > iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
> > iRowCount = 2
> >
> > sNameCol = InputBox("Enter Column Letter for Organization Name.",
> > "Organization Name Column", "Q")
> >
> > 'copy column for Organization Name to Column A
> > Columns(sNameCol).Select
> > Selection.Copy
> > Columns("A:A").Select
> > Selection.Insert Shift:=xlToRight
> > Range("A1").Select
> > ActiveCell.FormulaR1C1 = "Initial Scrub"
> >
> > 'Insert ScrubName Column
> > Columns("A:A").Select
> > Selection.Insert Shift:=xlToRight
> > Range("A1").Select
> > ActiveCell.FormulaR1C1 = "Scrubbed Org Name" & Chr(10) & "(Keywords
> > removed)"
> >
> > 'PERFORM INITIAL SCRUB
> > '__________________________________________________________________
> >
> > 'Find all periods and commas and "the"'s and other words that can be removed
> > entirely from names and remove from column B
> > Columns("B:B").Select
> > Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> > Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> > Selection.Replace What:="The ", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="Incorporated", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="GMBH", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="Corporation", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="Limited", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="LTD", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="LLC", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="LLP", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="Industries", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="Univ ", Replacement:="University ",
> > LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > Selection.Replace What:="-", Replacement:=" ", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> >
> > 'PERFORM SECONDARY SCRUB (this Do/Loop method takes much longer than inital
> > scrub,
> > ' therefore, if you can perform a scrub against the
> > whole
> > ' name, without worrying about multple instances,
> > then
> > ' perform the desired scrub using the initial scrub
> > ' method of Search/Replace)
> > '____________________________________________________________________
> >
> >
> > 'Run through all rows of data and trim leading and trailing spaces, plus
> > scrub out key words.
> > Do While iLastRow >= iRowCount
> > sName1 = Range("B" & iRowCount).Value
> > sName2 = UCase(Trim(sName1))
> > iName2 = Len(sName2)
> > sLessSpaces = Application.WorksheetFunction.Substitute(sName2, " ", "")
> > iLessSpaces = Len(sLessSpaces)
> >
> >
> > 'Test for multiple words in company name
> > If (iName2 - iLessSpaces) = 0 Then
> >
> > 'If none found then then leave as is
> > Result = sName2
> >
> > Else
> >
> > 'Converts the last space in a company name to a "^".
> > 'The instance of the last space is defined by the the diff between iName2
> > and iLessSpaces
> > '(which is the length of name with spaces, less the length of name without
> > spaces)
> > sLast = Application.WorksheetFunction.Substitute(sName2, " ", "^",
> > iName2 - iLessSpaces)
> > iLast = Application.WorksheetFunction.Find("^", sLast) + 1
> >
> > 'Lastword is equal to the word starting at the position of the "^" above +1
> > sLastword = UCase(Mid(sLast, iLast, 256))
> >
> > 'Search for each of these types of last words below and delete them off of
> > the trimmed name, also make the result uppercase.
> > 'The amount of positions to delete at the end is equal to the length of
> > characters plus 1 for the space before the last word.
> > 'This approach will only delete the word if it is the last word in the name,
> > unlike the search and replace all approach above created by the initial scrub.
> > Select Case (sLastword)
> >
> > Case "INC"
> > Result = Left(sName2, iName2 - 4)
> >
> > Case "USA"
> > Result = Left(sName2, iName2 - 4)
> >
> > Case "INTERNATIONAL"
> > Result = Left(sName2, iName2 - 14)
> >
> > Case "PC"
> > Result = Left(sName2, iName2 - 3)
> >
> > Case "APPLIANCES"
> > Result = Left(sName2, iName2 - 12)
> >
> > Case "SUPPLIES"
> > Result = Left(sName2, iName2 - 9)
> >
> > Case "SUPPLY"
> > Result = Left(sName2, iName2 - 7)
> >
> > Case "COMPANY"
> > Result = Left(sName2, iName2 - 8)
> >
> > Case "CORP"
> > Result = Left(sName2, iName2 - 5)
> >
> > Case "CO"
> > Result = Left(sName2, iName2 - 3)
> >
> > Case "IGT"
> > Result = Left(sName2, iName2 - 4)
> >
> > Case "SERVICES"
> > Result = Left(sName2, iName2 - 10)
> >
> > Case "SERVICES"
> > Result = Left(sName2, iName2 - 9)
> >
> > Case "TECHNOLOGIES"
> > Result = Left(sName2, iName2 - 13)
> >
> > Case "IND"
> > Result = Left(sName2, iName2 - 4)
> >
> >
> > Case Else
> > Result = sName2
> >
> > End Select
> >
> > End If
> >
> > 'Paste scrubbed results to Column A
> > Range("A" & iRowCount) = Result
> >
> > 'set next row to be evaluated
> > iRowCount = iRowCount + 1
> > Loop
> >
> > 'Delete the Initial Scrub Column and only leave the results for the
> > Secondary Scrub
> > Columns("B:B").Select
> > Selection.Delete Shift:=xlToLeft
> >
> > End Sub
> >
>

From your standpoint, the trickiest statement in my code is this one...

CellContents = Join(WorksheetFunction.Transpose(Range(sNameCol & "2:" &
sNameCol & LastRow)), Chr(1))

What it does is take the column letter you gave in answer to the InputBox
question and creates a range from it, then the worksheet's Transpose
function is applied against it to create a one-dimensional array from the
cell values in that range and, finally, those array values are joined
together into a single text string with a Chr(1) character placed between
each element (cell value). I used Chr(1) as the delimiter because I needed a
character that could not be in any of the cell values (I needed this because
later on I split the text string back into an array). Next, I just performed
the replacements your code indicated you needed to do. The beauty of putting
the cell values into a single text string is that each VB Replace function
call replaces *every* occurrence of the search string with that single
Replace function call (that way, no looping is required to process each cell
individually). Oh, and that intermediate Trim function call removes any
trailing space characters resulting from the removal of the characters that
were replaced with the empty string (""). Once all the replacements have
been completed, I use the Split function to break the single text string
back into a one-dimensional array and then put each array element back into
the cells.

--
Rick (MVP - Excel)


"Liz" <(E-Mail Removed)> wrote in message
news:9669F2DA-38DE-4842-8617-(E-Mail Removed)...
> Hi Rick -
> This works flawlessly! It appears very clean as well. Can you give me a
> brief explanation on how it works. I have not used this type of coding
> before.
>
> Thanks much!
> Liz
>
> "Rick Rothstein" wrote:
>
>> I think the following code does what your posted code does, but it uses
>> mostly built-in VB commands rather than continually reaching out for the
>> worksheet functions. As such, I believe it will be faster than your
>> current code. Make sure you test it out on a copy of your actual
>> worksheet as VB code cannot be undone by Excel's Undo command.
>>
>> Sub Scrub_Org_Name()
>> Dim X As Long
>> Dim LastRow As Long
>> Dim StartRow As Long
>> Dim sNameCol As String
>> Dim CellContents As String
>> Dim IndividualCellText() As String
>> StartRow = 2
>> sNameCol = InputBox("Enter Column Letter for Organization Name.",
>> "Organization Name Column", "Q")
>> LastRow = Cells(Rows.Count, sNameCol).End(xlUp).Row
>> CellContents = Join(WorksheetFunction.Transpose(Range(sNameCol & "2:" &
>> sNameCol & LastRow)), Chr(1))
>> CellContents = Replace(CellContents, ".", "")
>> CellContents = Replace(CellContents, ",", "")
>> CellContents = Replace(CellContents, "The ", "", , , vbTextCompare)
>> CellContents = Replace(CellContents, "Incorporated", "", , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, "GMBH", "", , , vbTextCompare)
>> CellContents = Replace(CellContents, "Corporation", "", , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, "Limited", "", , , vbTextCompare)
>> CellContents = Replace(CellContents, "LTD", "", , , vbTextCompare)
>> CellContents = Replace(CellContents, "LLC", "", , , vbTextCompare)
>> CellContents = Replace(CellContents, "LLP", "", , , vbTextCompare)
>> CellContents = Replace(CellContents, "Industries", "")
>> CellContents = Replace(CellContents, "Univ", "University", , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, "-", " ")
>> CellContents = WorksheetFunction.Trim(CellContents)
>> CellContents = Replace(CellContents, " " & Chr(1), Chr(1))
>> CellContents = Replace(CellContents, " INC" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " USA" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " INTERNATIONAL" & Chr(1), Chr(1),
>> , , vbTextCompare)
>> CellContents = Replace(CellContents, " PC" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " APPLIANCES" & Chr(1), Chr(1), ,
>> , vbTextCompare)
>> CellContents = Replace(CellContents, " SUPPLIES" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " SUPPLY" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " COMPANY" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " CORP" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " CO" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " IGT" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " SERVICES" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " SERVICES" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> CellContents = Replace(CellContents, " TECHNOLOGIES" & Chr(1), Chr(1),
>> , , vbTextCompare)
>> CellContents = Replace(CellContents, " IND" & Chr(1), Chr(1), , ,
>> vbTextCompare)
>> IndividualCellText = Split(CellContents, Chr(1))
>> Application.ScreenUpdating = False
>> Application.Calculation = xlManual
>> Columns("A").Insert Shift:=xlToRight
>> Range("A1").Value = "Scrubbed Org Name" & vbLf & "(Keywords removed)"
>> For X = StartRow To LastRow
>> Cells(X, "A").Value = IndividualCellText(X - StartRow)
>> Next
>> Columns("A").AutoFit
>> Application.Calculation = xlAutomatic
>> Application.ScreenUpdating = True
>> End Sub
>>
>> --
>> Rick (MVP - Excel)
>>
>>
>> "Liz" <(E-Mail Removed)> wrote in message
>> news:2EC5649D-35F2-4D4C-961F-(E-Mail Removed)...
>> > Hi,
>> > I have written a macro designed to scrub an organization's name so I
>> > can
>> > better match/compare its value. However, this macro takes 5 to 10
>> > minutes to
>> > process on over 1000 records (where the org name is just in one
>> > column).
>> >
>> > I am using the Select Case method to pull out the last word to check
>> > and
>> > remove certain common words. This seems to take the longest. Is there
>> > a
>> > better way to write the macro?
>> >
>> > Macro is below (Excel 2007):
>> >
>> > Sub Scrub_Org_Name()
>> >
>> > Dim sName1 As String
>> > Dim sName2 As String
>> > Dim iName2 As Integer
>> > Dim sLessSpaces As String
>> > Dim iLessSpaces As Integer
>> > Dim sLastword As String
>> > Dim iLast As Integer
>> > Dim sLast As String
>> > Dim iLastRow As Long
>> > Dim iRowCount As Long
>> > Dim sNameCol As String
>> > Dim Result As String
>> > Dim iReady As Integer
>> >
>> > iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
>> > iRowCount = 2
>> >
>> > sNameCol = InputBox("Enter Column Letter for Organization Name.",
>> > "Organization Name Column", "Q")
>> >
>> > 'copy column for Organization Name to Column A
>> > Columns(sNameCol).Select
>> > Selection.Copy
>> > Columns("A:A").Select
>> > Selection.Insert Shift:=xlToRight
>> > Range("A1").Select
>> > ActiveCell.FormulaR1C1 = "Initial Scrub"
>> >
>> > 'Insert ScrubName Column
>> > Columns("A:A").Select
>> > Selection.Insert Shift:=xlToRight
>> > Range("A1").Select
>> > ActiveCell.FormulaR1C1 = "Scrubbed Org Name" & Chr(10) & "(Keywords
>> > removed)"
>> >
>> > 'PERFORM INITIAL SCRUB
>> > '__________________________________________________________________
>> >
>> > 'Find all periods and commas and "the"'s and other words that can be
>> > removed
>> > entirely from names and remove from column B
>> > Columns("B:B").Select
>> > Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> > Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> > Selection.Replace What:="The ", Replacement:="", LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="Incorporated", Replacement:="",
>> > LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="GMBH", Replacement:="", LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="Corporation", Replacement:="",
>> > LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="Limited", Replacement:="", LookAt:=xlPart,
>> > _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="LTD", Replacement:="", LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="LLC", Replacement:="", LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="LLP", Replacement:="", LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="Industries", Replacement:="",
>> > LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="Univ ", Replacement:="University ",
>> > LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> > Selection.Replace What:="-", Replacement:=" ", LookAt:=xlPart, _
>> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
>> > ReplaceFormat:=False
>> >
>> >
>> > 'PERFORM SECONDARY SCRUB (this Do/Loop method takes much longer than
>> > inital
>> > scrub,
>> > ' therefore, if you can perform a scrub
>> > against the
>> > whole
>> > ' name, without worrying about multple
>> > instances,
>> > then
>> > ' perform the desired scrub using the
>> > initial scrub
>> > ' method of Search/Replace)
>> > '____________________________________________________________________
>> >
>> >
>> > 'Run through all rows of data and trim leading and trailing spaces,
>> > plus
>> > scrub out key words.
>> > Do While iLastRow >= iRowCount
>> > sName1 = Range("B" & iRowCount).Value
>> > sName2 = UCase(Trim(sName1))
>> > iName2 = Len(sName2)
>> > sLessSpaces = Application.WorksheetFunction.Substitute(sName2, " ",
>> > "")
>> > iLessSpaces = Len(sLessSpaces)
>> >
>> >
>> > 'Test for multiple words in company name
>> > If (iName2 - iLessSpaces) = 0 Then
>> >
>> > 'If none found then then leave as is
>> > Result = sName2
>> >
>> > Else
>> >
>> > 'Converts the last space in a company name to a "^".
>> > 'The instance of the last space is defined by the the diff between
>> > iName2
>> > and iLessSpaces
>> > '(which is the length of name with spaces, less the length of name
>> > without
>> > spaces)
>> > sLast = Application.WorksheetFunction.Substitute(sName2, " ", "^",
>> > iName2 - iLessSpaces)
>> > iLast = Application.WorksheetFunction.Find("^", sLast) + 1
>> >
>> > 'Lastword is equal to the word starting at the position of the "^"
>> > above +1
>> > sLastword = UCase(Mid(sLast, iLast, 256))
>> >
>> > 'Search for each of these types of last words below and delete them off
>> > of
>> > the trimmed name, also make the result uppercase.
>> > 'The amount of positions to delete at the end is equal to the length of
>> > characters plus 1 for the space before the last word.
>> > 'This approach will only delete the word if it is the last word in the
>> > name,
>> > unlike the search and replace all approach above created by the initial
>> > scrub.
>> > Select Case (sLastword)
>> >
>> > Case "INC"
>> > Result = Left(sName2, iName2 - 4)
>> >
>> > Case "USA"
>> > Result = Left(sName2, iName2 - 4)
>> >
>> > Case "INTERNATIONAL"
>> > Result = Left(sName2, iName2 - 14)
>> >
>> > Case "PC"
>> > Result = Left(sName2, iName2 - 3)
>> >
>> > Case "APPLIANCES"
>> > Result = Left(sName2, iName2 - 12)
>> >
>> > Case "SUPPLIES"
>> > Result = Left(sName2, iName2 - 9)
>> >
>> > Case "SUPPLY"
>> > Result = Left(sName2, iName2 - 7)
>> >
>> > Case "COMPANY"
>> > Result = Left(sName2, iName2 - 8)
>> >
>> > Case "CORP"
>> > Result = Left(sName2, iName2 - 5)
>> >
>> > Case "CO"
>> > Result = Left(sName2, iName2 - 3)
>> >
>> > Case "IGT"
>> > Result = Left(sName2, iName2 - 4)
>> >
>> > Case "SERVICES"
>> > Result = Left(sName2, iName2 - 10)
>> >
>> > Case "SERVICES"
>> > Result = Left(sName2, iName2 - 9)
>> >
>> > Case "TECHNOLOGIES"
>> > Result = Left(sName2, iName2 - 13)
>> >
>> > Case "IND"
>> > Result = Left(sName2, iName2 - 4)
>> >
>> >
>> > Case Else
>> > Result = sName2
>> >
>> > End Select
>> >
>> > End If
>> >
>> > 'Paste scrubbed results to Column A
>> > Range("A" & iRowCount) = Result
>> >
>> > 'set next row to be evaluated
>> > iRowCount = iRowCount + 1
>> > Loop
>> >
>> > 'Delete the Initial Scrub Column and only leave the results for the
>> > Secondary Scrub
>> > Columns("B:B").Select
>> > Selection.Delete Shift:=xlToLeft
>> >
>> > End Sub
>> >
>>