AdvancedFilter in Excel is running very slowly

Question

Hi All and thanks in advance,

I am new to coding in VBA and have been making an spreadsheet that searches a list of questions and answers for keywords. I have got it all working the way I want, but it takes a long time to run.

Basically the data is all in hidden rows on the same spreadsheet as the search button, there are five columns that can be searched, each has a checkbox, which when checked means the column is included in the filter. The user inputs their keyword(s) and then the macros set up the advanced filter with a look up on another sheet. The rows the meet the criteria are then displayed while the others still remain hidden.

I have tried a few things to speed up the macros but it still takes a long time. the more rows meet the criteria the longer it takes.

I look forward to hearing your ideas!

I have added my code below.

Matt

Sub Macro7()


With Application
     .Calculation = xlCalculationManual
     .ScreenUpdating = False
End With

Dim searchthis As String
Dim vCount As Integer
Dim vCell As String
Dim vContent As String
Dim vRange As String
Dim vHiddenT As Integer
Dim vHiddenF As Integer
vCount = 0
searchthis = InputBox("Type criteria to search to data", "Proposal Answers Search")

If searchthis = "" Then
    vCount = MsgBox("No search criteria entered", vbOKOnly, "Proposal Answers Search")
    Exit Sub
End If

If Len(searchthis) < 3 Then
    vCount = MsgBox("Are you sure that you wish to search for:  " & searchthis & "?", vbYesNo, "Proposal Answers Search")
    If vCount = 7 Then
        Exit Sub
    End If
End If

Dim vArray As Variant
vArray = MySplitFunction(searchthis)
Sheets("LookupRange").Activate
Sheets("LookupRange").Cells.Select
Sheets("LookupRange").Range("A1").Activate
Selection.ClearContents
Sheets("LookupRange").Range("A1") = "RFP Name"
Sheets("LookupRange").Range("B1") = "Question #"
Sheets("LookupRange").Range("C1") = "Question Title"
Sheets("LookupRange").Range("D1") = "Question"
Sheets("LookupRange").Range("E1") = "Answer"
vCount = 0
vContent = vArray(0)

If UBound(vArray) > 0 Then
    For i = 1 To UBound(vArray)
        vContent = vContent & vArray(i)
    Next
End If

Dim vArray2 As Variant
Dim vCell3 As String
vArray2 = CheckBoxCheck

If UBound(vArray2) >= 1 Then
    For i = 0 To UBound(vArray2) - 1
        vCell3 = vArray2(i)
        Sheets("LookupRange").Range(vCell3) = vContent
    Next
Else
    vCount = MsgBox("No CheckBox selected", vbOKOnly, "Proposal Answers Search")
    Exit Sub
End If

Dim aRng As Range
Dim FirstCell As String
Dim LastCell As String
Sheets("LookupRange").Activate
Set aRng = Sheets("LookupRange").Range("A1").CurrentRegion
FirstCell = "A1"
LastCell = "E" & aRng.Rows.Count
vRange = FirstCell & ":" & LastCell

Sheets("Data").Activate
Sheets("Data").Range("A327").Activate

Do
        ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Value = ""

vHiddenF = ActiveCell.Row
vStr = "A6:E" & vHiddenF - 1

Application.CutCopyMode = False
Range(vStr).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("LookupRange").Range(vRange), Unique:=False

Sheets("Data").Range("A1") = "Search Term"
Sheets("Data").Range("A2") = searchthis
Sheets("Data").Range("A6") = "RFP Name"
Sheets("Data").Range("B6") = "Question #"
Sheets("Data").Range("C6") = "Question Title"
Sheets("Data").Range("D6") = "Question"
Sheets("Data").Range("E6") = "Answer"
Sheets("Data").Range("A1").Activate

With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

End Sub



Function MySplitFunction(s As String) As String()

Dim temp As String
Dim Output() As String

Do
    temp = s
    s = Replace(s, "  ", " ")
Loop Until temp = s

Output = Split(Trim(s), " ")

For i = 0 To UBound(Output)
    Output(i) = "*" & Output(i) & "*"
Next

MySplitFunction = Output

End Function



Function CheckBoxCheck() As String()

Dim vTemp As String
Dim vOutput() As String
Dim vCount As Integer
vCount = 2

If Sheets("Data").Shapes("Check Box 7").ControlFormat.Value = 1 Then
    vTemp = "A" & vCount
    vCount = vCount + 1
End If

If Sheets("Data").Shapes("Check Box 8").ControlFormat.Value = 1 Then
    vTemp = vTemp & "B" & vCount
    vCount = vCount + 1
End If

If Sheets("Data").Shapes("Check Box 9").ControlFormat.Value = 1 Then
    vTemp = vTemp & "C" & vCount
    vCount = vCount + 1
End If

If Sheets("Data").Shapes("Check Box 10").ControlFormat.Value = 1 Then
    vTemp = vTemp & "D" & vCount
    vCount = vCount + 1
End If

If Sheets("Data").Shapes("Check Box 11").ControlFormat.Value = 1 Then
    vTemp = vTemp & "E" & vCount
End If

Dim sArr() As String
Dim nCount As Long
Dim numOfChar As Integer
numOfChar = 2
ReDim sArr(Len(vTemp) \ numOfChar)

Do While Len(vTemp)
    sArr(nCount) = Left$(vTemp, numOfChar)
    vTemp = Mid$(vTemp, numOfChar + 1)
    nCount = nCount + 1
Loop

CheckBoxCheck = sArr

End Function

Dont use .select and .activate .it slows down your code .. To know about that more see >http://stackoverflow.com/questions/10714251/excel-macro-avoiding-using-select — Sathish Kothandam, Mar 13 '14 at 02:40

score 0 · Answer 1 · answered Mar 13 '14 at 03:14

Your main culprit might be this:

Sheets("Data").Activate
Sheets("Data").Range("A327").Activate

Do
    ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Value = ""

The Active & Select may loop for hundreds of cells if you have a lot of data and will eat up processing time. It appears that your simply looking for the next empty row. Try this instead one line in place of all the above:

vHiddenF = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row + 1

Here are a few suggested ways to get rid of Select and Active statements in your main macro:

Sub Macro7()
    With Application
         .Calculation = xlCalculationManual
         .ScreenUpdating = False
    End With

    Dim searchthis As String
    Dim vCount As Integer
    Dim vCell As String
    Dim vContent As String
    Dim vRange As String
    Dim vHiddenT As Integer
    Dim vHiddenF As Integer
    vCount = 0
    searchthis = InputBox("Type criteria to search to data", "Proposal Answers Search")

    If searchthis = "" Then
        vCount = MsgBox("No search criteria entered", vbOKOnly, "Proposal Answers Search")
        Exit Sub
    End If

    If Len(searchthis) < 3 Then
        vCount = MsgBox("Are you sure that you wish to search for:  " & searchthis & "?", vbYesNo, "Proposal Answers Search")
        If vCount = 7 Then
            Exit Sub
        End If
    End If

    Dim wkLookUpRange As Worksheet
    Set wkLookUpRange = Sheets("LookupRange")

    Dim vArray As Variant
    vArray = MySplitFunction(searchthis)

    wkLookUpRange.Cells.ClearContents
    wkLookUpRange.Range("A1") = "RFP Name"
    wkLookUpRange.Range("B1") = "Question #"
    wkLookUpRange.Range("C1") = "Question Title"
    wkLookUpRange.Range("D1") = "Question"
    wkLookUpRange.Range("E1") = "Answer"
    vCount = 0
    vContent = vArray(0)

    If UBound(vArray) > 0 Then
        For i = 1 To UBound(vArray)
            vContent = vContent & vArray(i)
        Next
    End If

    Dim vArray2 As Variant
    Dim vCell3 As String
    vArray2 = CheckBoxCheck

    If UBound(vArray2) >= 1 Then
        For i = 0 To UBound(vArray2) - 1
            vCell3 = vArray2(i)
            wkLookUpRange.Range(vCell3) = vContent
        Next
    Else
        vCount = MsgBox("No CheckBox selected", vbOKOnly, "Proposal Answers Search")
        Exit Sub
    End If

    Dim aRng As Range
    Dim FirstCell As String
    Dim LastCell As String

    Set aRng = wkLookUpRange.Range("A1").CurrentRegion
    FirstCell = "A1"
    LastCell = "E" & aRng.Rows.Count
    vRange = FirstCell & ":" & LastCell

    Dim wkData As Worksheet
    Set wkData = Sheets("Data")

    vHiddenF = wkData.Range("A" & Rows.Count).End(xlUp).Row + 1

    vStr = "A6:E" & vHiddenF - 1

    Application.CutCopyMode = False
    wkData.Range(vStr).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
    wkLookUpRange.Range(vRange), Unique:=False

    wkData.Range("A1") = "Search Term"
    wkData.Range("A2") = searchthis
    wkData.Range("A6") = "RFP Name"
    wkData.Range("B6") = "Question #"
    wkData.Range("C6") = "Question Title"
    wkData.Range("D6") = "Question"
    wkData.Range("E6") = "Answer"
    wkData.Range("A1").Activate

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Thanks for the answer, the line that you gave me doesnt work though. i dont this it takes hidden rows into account. I used "A327" because there are only 329 rows. — user3413247, Mar 13 '14 at 03:37
Your right, it doesn't take into account hidden rows. I think your best bet is to unhide all rows first since it sounds like your re-applying the filter and hidden rows at the end. — Automate This, Mar 13 '14 at 03:41

AdvancedFilter in Excel is running very slowly

1 Answers1