none
Macro Extremely slow in Excel 2013 RRS feed

  • Question

  • Hello,

    I'm using the following code to search the whole table(over 37 000 lines) and filter the results.

    It runs perfectly in excel 2010- 5 sec, but in excel 2013 in takes over a minute. Would appreciate your assistance to make this run faster?

    *******

    Sub Search_Click()
    Dim objListObj As ListObject
    Dim objQryTbl As QueryTable
    Dim tblRange As Range
    Dim searchterm As String
    Dim c As Range
    Dim colRowsToShow As Collection
    Dim colCounter As Long
    Dim Range As Long
    Application.ScreenUpdating = False
    Set objListObj = main.ListObjects(1)
    Set tblRange = objListObj.QueryTable.ResultRange
    searchterm = Trim(main.Range("keyword"))
    If Len(searchterm) > 500 Then
        MsgBox "Only 500 characters are allowed in the search term"
        Exit Sub
    End If
    'If MsgBox("This needs to clear any auto-filter applied on any colum in order to work." & vbCrLf & _
    '"Click YES if this is OK, click NO to cancel.", vbYesNo) = vbNo Then
        'Exit Sub
    'End If
    tblRange.AutoFilter
    tblRange.AutoFilter
    tblRange.EntireRow.Hidden = False
    If searchterm = "" Then
       
        Exit Sub
       
    End If
    Set tblRange = tblRange.Offset(1, 0).Resize(tblRange.Rows.Count - 1)
    Set colRowsToShow = New Collection
    '
    With tblRange
        Set c = .Find(searchterm, LookIn:=xlValues, MatchCase:=False, LookAt:=xlPart)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                colRowsToShow.Add c.Row
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
    tblRange.EntireRow.Hidden = True
    If colRowsToShow.Count > 0 Then
        For colCounter = 1 To colRowsToShow.Count
            Debug.Print colRowsToShow.Item(colCounter)
            main.Range("A" & colRowsToShow.Item(colCounter)).EntireRow.Hidden = False
        Next
    End If
    'tblRange.Find
    End Sub

    *********

    Tuesday, August 18, 2015 3:14 AM

Answers

  • It runs perfectly in excel 2010- 5 sec, but in excel 2013 in takes over a minute.

    You are on the right way, the bottle neck in your code is to hide/unhide all the rows one by one.
    We can speed up the process (a little) when we search and combine all found cells into on Range object and unhide all in one step.

    BTW, you should not declare variables with names from objects, delete this line:
      Dim Range As Long
    it is not used in your code.

    In your sub delete any line after this line
      Set tblRange = tblRange.Offset(1, 0).Resize(tblRange.Rows.Count - 1)
    and use this lines instead:

      Dim Result As Range
      Set Result = FindAll(tblRange, searchterm, LookAt:=xlPart)
      tblRange.EntireRow.Hidden = True
      If Not Result Is Nothing Then Result.EntireRow.Hidden = False

    The function FindAll is below.

    BTW2, I guess a much faster way would be if you add a helper column as "search result" and write e.g. a "x" (with the use of an array) into each row where the search term is found, then use the AutoFilter to show the results.

      ReDim Data(1 To tblRange.Rows.Count, 1 To 1)
      Dim BaseRow As Long
      BaseRow = tblRange.Row - 1
      With tblRange
        Set c = .Find(searchterm, LookIn:=xlValues, MatchCase:=False, LookAt:=xlPart)
        If Not c Is Nothing Then
          FirstAddress = c.Address
          Do
            Data(c.Row - BaseRow, 1) = "x"
            Set c = .FindNext(c)
          Loop Until c.Address = FirstAddress
          'Add after the last column
          .Columns(.Columns.Count + 1).Cells(1, 1).Resize(UBound(Data), UBound(Data, 2)) = Data
          'Filter the "x"
          .AutoFilter .Columns.Count + 1, "x"
        End If
      End With

    But that might not be an option...

    Andreas.

     
    Function FindAll(ByVal Where As Range, ByVal What, _
        Optional ByVal After As Variant, _
        Optional ByVal LookIn As XlFindLookIn = xlValues, _
        Optional ByVal LookAt As XlLookAt = xlWhole, _
        Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
        Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
        Optional ByVal MatchCase As Boolean = False, _
        Optional ByVal SearchFormat As Boolean = False) As Range
      'Find all occurrences of What in Where (Windows version)
      Dim FirstAddress As String
      Dim c As Range
      'From FastUnion:
      Dim Stack As New Collection
      Dim Temp() As Range, Item
      Dim i As Long, j As Long
    
      If Where Is Nothing Then Exit Function
      If SearchDirection = xlNext And IsMissing(After) Then
        'Set After to the last cell in Where to return the first cell in Where in front if _
          it match What
        Set c = Where.Areas(Where.Areas.Count)
        'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
        'Set After = C.Cells(C.Cells.Count)
        Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))
      End If
    
      Set c = Where.Find(What, After, LookIn, LookAt, SearchOrder, _
        SearchDirection, MatchCase, SearchFormat:=SearchFormat)
      If c Is Nothing Then Exit Function
    
      FirstAddress = c.Address
      Do
        Stack.Add c
        If SearchFormat Then
          'If you call this function from an UDF and _
            you find only the first cell use this instead
          Set c = Where.Find(What, c, LookIn, LookAt, SearchOrder, _
            SearchDirection, MatchCase, SearchFormat:=SearchFormat)
        Else
          If SearchDirection = xlNext Then
            Set c = Where.FindNext(c)
          Else
            Set c = Where.FindPrevious(c)
          End If
        End If
        'Can happen if we have merged cells
        If c Is Nothing Then Exit Do
      Loop Until FirstAddress = c.Address
    
      'FastUnion algorithm © Andreas Killer, 2011:
      'Get all cells as fragments
      ReDim Temp(0 To Stack.Count - 1)
      i = 0
      For Each Item In Stack
        Set Temp(i) = Item
        i = i + 1
      Next
      'Combine each fragment with the next one
      j = 1
      Do
        For i = 0 To UBound(Temp) - j Step j * 2
          Set Temp(i) = Union(Temp(i), Temp(i + j))
        Next
        j = j * 2
      Loop Until j > UBound(Temp)
      'At this point we have all cells in the first fragment
      Set FindAll = Temp(0)
    End Function
    

    Tuesday, August 18, 2015 10:04 AM

All replies

  • You could use advanced filtering for this (not sure if it'll perform better though).

    Somewhere above your table (assuming the table starts at cell A5 and your search string is in A1), in cell Z2 enter this formula (any other cell NOT on row 1 will do of course, as long as it is not on the same row as a table row):

    =OR(NOT(ISERROR(FIND($A$1,A6))),NOT(ISERROR(FIND($A$1,B6))),NOT(ISERROR(FIND($A$1,C6))))

    Now select advanced filter and enter cells Z1 and Z2 as criteria area. Make SURE cell Z1 is EMPTY.

    Apply the advanced filter (record macro while doing so).


    Regards, Jan Karel Pieterse|Excel MVP|http://www.jkp-ads.com

    Tuesday, August 18, 2015 8:36 AM
  • It runs perfectly in excel 2010- 5 sec, but in excel 2013 in takes over a minute.

    You are on the right way, the bottle neck in your code is to hide/unhide all the rows one by one.
    We can speed up the process (a little) when we search and combine all found cells into on Range object and unhide all in one step.

    BTW, you should not declare variables with names from objects, delete this line:
      Dim Range As Long
    it is not used in your code.

    In your sub delete any line after this line
      Set tblRange = tblRange.Offset(1, 0).Resize(tblRange.Rows.Count - 1)
    and use this lines instead:

      Dim Result As Range
      Set Result = FindAll(tblRange, searchterm, LookAt:=xlPart)
      tblRange.EntireRow.Hidden = True
      If Not Result Is Nothing Then Result.EntireRow.Hidden = False

    The function FindAll is below.

    BTW2, I guess a much faster way would be if you add a helper column as "search result" and write e.g. a "x" (with the use of an array) into each row where the search term is found, then use the AutoFilter to show the results.

      ReDim Data(1 To tblRange.Rows.Count, 1 To 1)
      Dim BaseRow As Long
      BaseRow = tblRange.Row - 1
      With tblRange
        Set c = .Find(searchterm, LookIn:=xlValues, MatchCase:=False, LookAt:=xlPart)
        If Not c Is Nothing Then
          FirstAddress = c.Address
          Do
            Data(c.Row - BaseRow, 1) = "x"
            Set c = .FindNext(c)
          Loop Until c.Address = FirstAddress
          'Add after the last column
          .Columns(.Columns.Count + 1).Cells(1, 1).Resize(UBound(Data), UBound(Data, 2)) = Data
          'Filter the "x"
          .AutoFilter .Columns.Count + 1, "x"
        End If
      End With

    But that might not be an option...

    Andreas.

     
    Function FindAll(ByVal Where As Range, ByVal What, _
        Optional ByVal After As Variant, _
        Optional ByVal LookIn As XlFindLookIn = xlValues, _
        Optional ByVal LookAt As XlLookAt = xlWhole, _
        Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
        Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
        Optional ByVal MatchCase As Boolean = False, _
        Optional ByVal SearchFormat As Boolean = False) As Range
      'Find all occurrences of What in Where (Windows version)
      Dim FirstAddress As String
      Dim c As Range
      'From FastUnion:
      Dim Stack As New Collection
      Dim Temp() As Range, Item
      Dim i As Long, j As Long
    
      If Where Is Nothing Then Exit Function
      If SearchDirection = xlNext And IsMissing(After) Then
        'Set After to the last cell in Where to return the first cell in Where in front if _
          it match What
        Set c = Where.Areas(Where.Areas.Count)
        'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
        'Set After = C.Cells(C.Cells.Count)
        Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))
      End If
    
      Set c = Where.Find(What, After, LookIn, LookAt, SearchOrder, _
        SearchDirection, MatchCase, SearchFormat:=SearchFormat)
      If c Is Nothing Then Exit Function
    
      FirstAddress = c.Address
      Do
        Stack.Add c
        If SearchFormat Then
          'If you call this function from an UDF and _
            you find only the first cell use this instead
          Set c = Where.Find(What, c, LookIn, LookAt, SearchOrder, _
            SearchDirection, MatchCase, SearchFormat:=SearchFormat)
        Else
          If SearchDirection = xlNext Then
            Set c = Where.FindNext(c)
          Else
            Set c = Where.FindPrevious(c)
          End If
        End If
        'Can happen if we have merged cells
        If c Is Nothing Then Exit Do
      Loop Until FirstAddress = c.Address
    
      'FastUnion algorithm © Andreas Killer, 2011:
      'Get all cells as fragments
      ReDim Temp(0 To Stack.Count - 1)
      i = 0
      For Each Item In Stack
        Set Temp(i) = Item
        i = i + 1
      Next
      'Combine each fragment with the next one
      j = 1
      Do
        For i = 0 To UBound(Temp) - j Step j * 2
          Set Temp(i) = Union(Temp(i), Temp(i + j))
        Next
        j = j * 2
      Loop Until j > UBound(Temp)
      'At this point we have all cells in the first fragment
      Set FindAll = Temp(0)
    End Function
    

    Tuesday, August 18, 2015 10:04 AM
  • Thank you, this works, however it is case- sensitive. How can i make it so that it's not case-sensitive (search both upper and lower case) ?
    Monday, August 24, 2015 5:54 AM
  • Range.Find (and therefore my function FindAll) has a MatchCase argument, set it to True.

    Monday, August 24, 2015 7:04 AM
  • instead of FIND, use SEARCH.

    Regards, Jan Karel Pieterse|Excel MVP|http://www.jkp-ads.com

    Monday, August 24, 2015 9:34 AM