Can I improve processing speed of macro

L

Liz

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
 
G

Gary''s Student

First try this:

Sub main()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Call Scurb_Org_Name
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
 
R

Rick Rothstein

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
 
L

Liz

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
 
R

Rick Rothstein

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.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

find and replace multiple values in one statement 3
Help with a loop please. 10
Find and Replace Help 3
Macro to select columns and replace data 6
Need help with a "If" "Else" VB code 4
VBA to Fix Dates 5
Slow Macro 7
Printing Macro 4

Top