Speed up loop in excel - vba

Question

I had some great help to get this search tool working in excel but I was wondering if there is room for speed improvement. I did some research and with what little I understand about VB for i = LBOUND(array) To UBOUND(array) seems most optimal. Would 'For Each' be faster? I am wondering if there is a way to isolate the records currently in the worksheet, or if it is already doing this with L/UBOUND? If it is, is there a way to do 'ignore special characters' similar to SQL? After adding screenupdating and calculation, I was able to shave about 10 seconds off of the total run time. And further I was using FormulaR1C1 for my search before this new loop and it would limit the amount of columns to search while being super fast.
Range("W2:W" & LastRow).FormulaR1C1 = _
"=IF(ISERR(SEARCH(R1C23,RC[-22]&RC[-21]&RC[-20]&RC[-19]&RC[-18]&RC[-17]&RC[-16]&RC[-15]&RC[-15]&RC[-14]&RC[-13]&RC[-12]&RC[-11]&RC[-10]&RC[-9]&RC[-8]&RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1])),0,1)"
If WorksheetFunction.CountIf(Columns(23), 1) = 0 Then
Columns(23).Delete
Any help or recommendations are greatly appreciated.
Sub FindFeature()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim shResults As Worksheet
Dim vaData As Variant
Dim i As Long, j As Long
Dim sSearchTerm As String
Dim sData As String
Dim rNext As Range
Dim v As Variant
Dim vaDataCopy As Variant
Dim uRange As Range
Dim findRange As Range
Dim nxtRange As Range
Dim ws As Range
'Put all the data into an array
vaData = ActiveSheet.UsedRange.Value
'Get the search term
sSearchTerm = Application.InputBox("What are you looking for?")
'Define and clear the results sheet
Set shResults = ActiveWorkbook.Worksheets("Results")
shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete
Set uRange = ActiveSheet.UsedRange
vaData = uRange.Value
vaDataCopy = vaData
For Each v In vaDataCopy
v = Anglicize(v)
Next
Application.WorksheetFunction.Transpose (vaDataCopy)
ActiveSheet.UsedRange.Value = vaDataCopy
'Loop through the data
Set ws = Cells.Find(What:=uRange, After:="ActiveCell", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not ws Is Nothing Then
Set findRange = ws
Do
Set nxtRange = Cells.FindNext(After:=ws)
Set findRange = nxtRange
Loop Until ws.Address = findRange.Address
ActiveSheet.UsedRange.Value = vaData
'Write the row to the next available row on Results
Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
rNext.Resize(1, uRange(vaData, 2)).Value = Application.Index(vaData, i, 0)
'Stop looking in that row after one match
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Answer 1

Ultimately, the execution speed here is severely hampered by the apparent requirement to operate on every cell in the range, and because you're asking about performance, I suspect this range may contain many thousands of cells. There are two things I can think of:
1. Save your results in an array and write to the Results worksheet in one statement
Try replacing this:
'Write the row to the next available row on Results
Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
rNext.Resize(1, UBound(vaData, 2)).Value = Application.Index(vaData, i, 0)
'Stop looking in that row after one match
Exit For
With a statement that assigns the value Application.Index(vaData, i, 0) to an array variable, and then when you're completed the For i loop, you can write the results in one pass to the results worksheet.
NOTE This may be noticeably faster if and only if there are many thousands of results. If there are only a few results expected, then exeuction speed is primarily affected by the need to iterate over every cell, not the operation of writing the results to another sheet.
2. Use another method than cell iteration
If you can implement this method, I would use it in conjunction with the above.
Ordinarily I would recommend using the .Find and .FindNext methods as considerably more efficient than using the i,j iteration. But since you need to use the Anglicize UDF on every cell in the range, you would need to make some restructure your code to accommodate. Might require multiple loops, for example, first Anglicize the vaData and preserve a copy of the non-Anglicized data, like:
Dim r as Long, c as Long
Dim vaDataCopy as Variant
Dim uRange as Range
Set uRange = ActiveSheet.UsedRange
vaData = uRange.Value
vaDataCopy = vaData
For r = 1 to Ubound(varDataCopy,1)
For c = 1 to Ubound(varDataCopy,2)
varDataCopy(r,c) = Anglicize(varDataCopy(r,c))
Next
Next
Then, put the Anglicize version on to the worksheet.
ActiveSheet.UsedRange.Value = vaDataCopy
Then, instead of the For i =... For j =... loop, use the .Find and .FindNext method on the uRange object.
Here is an example of how I implement Find/FindNext.
Finally, put the non-Anglicized version back on the worksheet, again with the caveat that it might require use of Transpose function:
ActiveSheet.UsedRange.Value = vaData
Whil this still iterates over every value to perform the Anglicize function, it does not operate on every value a second time (Instr function). So, you're essentially operating on the values only once, rather than twice. I suspect this should be much faster, especially if you combine it with the #1 above.
UPDATE BASED ON OP REVISION EFFORTS
After some comment discussion & emails back and forth, we arrive at this solution:
Option Explicit
Sub FindFeature()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim shSearch As Worksheet:
Dim shResults As Worksheet
Dim vaData As Variant
Dim i As Long, j As Long, r As Long, c As Long
Dim sSearchTerm As String
Dim sData As String
Dim rNext As Range
Dim v As Variant
Dim vaDataCopy As Variant
Dim uRange As Range
Dim findRange As Range
Dim nxtRange As Range
Dim rng As Range
Dim foundRows As Object
Dim k As Variant
Set shSearch = Sheets("City")
shSearch.Activate
'Define and clear the results sheet
Set shResults = ActiveWorkbook.Worksheets("Results")
shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete
'# Create a dictionary to store our result rows
Set foundRows = CreateObject("Scripting.Dictionary")
'Get the search term
sSearchTerm = Application.InputBox("What are you looking for?")
'# set and fill our range/array variables
Set uRange = shSearch.UsedRange
vaData = uRange.Value
vaDataCopy = Application.Transpose(vaData)
For r = 1 To UBound(vaDataCopy, 1)
For c = 1 To UBound(vaDataCopy, 2)
'MsgBox uRange.Address
vaDataCopy(r, c) = Anglicize(vaDataCopy(r, c))
Next
Next
'# Temporarily put the anglicized text on the worksheet
uRange.Value = Application.Transpose(vaDataCopy)
'# Loop through the data, finding instances of the sSearchTerm
With uRange
.Cells(1, 1).Activate
Set rng = .Cells.Find(What:=sSearchTerm, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not rng Is Nothing Then
Set findRange = rng
Do
Set nxtRange = .Cells.FindNext(After:=findRange)
Debug.Print sSearchTerm & " found at " & nxtRange.Address
If Not foundRows.Exists(nxtRange.Row) Then
'# Make sure we're not storing the same row# multiple times.
'# store the row# in a Dictionary
foundRows.Add nxtRange.Row, nxtRange.Column
End If
Set findRange = nxtRange
'# iterate over all matches, but stop when the FindNext brings us back to the first match
Loop Until findRange.Address = rng.Address
'# Iterate over the keys in the Dictionary. This contains the ROW# where a match was found
For Each k In foundRows.Keys
'# Find the next empty row on results page:
With shResults
Set rNext = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0). _
Resize(1, UBound(Application.Transpose(vaData), 1))
End With
'# Write the row to the next available row on Results
rNext.Value = Application.Index(vaData, k, 0)
Next
Else:
MsgBox sSearchTerm & " was not found"
End If
End With
'# Put the non-Anglicized values back on the sheet
uRange.Value = vaData
'# Restore application properties
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'# Display the results
shResults.Activate
End Sub
Public Function Anglicize(ByVal sInput As String) As String
Dim vaGood As Variant
Dim vaBad As Variant
Dim i As Long
Dim sReturn As String
Dim c As Range
'Replace any 'bad' characters with 'good' characters
vaGood = Split("S,Z,s,z,Y,A,A,A,A,A,A,C,E,E,E,E,I,I,I,I,D,N,O,O,O,O,O,U,U,U,U,Y,a,a,a,a,a,a,c,e,e,e,e,i,i,i,i,d,n,o,o,o,o,o,u,u,u,u,y,y", ",")
vaBad = Split("Š,Ž,š,ž,Ÿ,À,Á,Â,Ã,Ä,Å,Ç,È,É,Ê,Ë,Ì,Í,Î,Ï,Ð,Ñ,Ò,Ó,Ô,Õ,Ö,Ù,Ú,Û,Ü,Ý,à,á,â,ã,ä,å,ç,è,é,ê,ë,ì,í,î,ï,ð,ñ,ò,ó,ô,õ,ö,ù,ú,û,ü,ý,ÿ", ",")
sReturn = sInput
Set c = Range("D1:G1")
For i = LBound(vaBad) To UBound(vaBad)
sReturn = Replace$(sReturn, vaBad(i), vaGood(i))
Next i
Anglicize = sReturn
'Sheets("Results").Activate
End Function