0

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
3
  • 1
    Specialcells may add some improvement by letting you search through fewer cells msdn.microsoft.com/en-us/library/office/…
    – Jesse
    Jul 2, 2013 at 14:10
  • Is the version of Anglicize being used the same as the one in the original version of this question - stackoverflow.com/revisions/17427039/1 If so, there's a very unnecessary Sheets("Results").Activate line in there which might be having an effect on performance
    – barrowc
    Jul 3, 2013 at 1:09
  • Unfortunately, it is a must have feature. Unless there is a better way to do it. Maybe a msgbox and then a transfer after?
    – cbrannin
    Jul 3, 2013 at 13:02

1 Answer 1

4

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
18
  • Would it be easier to limit using the Anglicize to 2 columns? There are only 2 columns that that function needs to run on?
    – cbrannin
    Jul 2, 2013 at 17:11
  • Appears to not help any. Your logic is spot on. My only issue is I am unsure how to implement it, haha. I will work on your suggestion. Thank you!
    – cbrannin
    Jul 2, 2013 at 17:42
  • @cbrannin yes, that would be easier. Still, if you have for example, 100,000 rows of data, that's 200,000 cells, so execution speed will still be slow, I think. Jul 2, 2013 at 17:43
  • @cbrannin if you get stuck trying to implement my suggestsions, go ahead and revise your original question to include the new code that you are trying to use. I can take a look at it tonight and try to offer some more help. Jul 2, 2013 at 17:52
  • OK. there is a problem with the first part of my #2 suggestion. I revised above. Let's start with that and then troubleshoot the Find loop. Jul 3, 2013 at 2:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.