Nsryjdtyk

Follow-up to VBA macro - searches through a filtered table, stops when entry passes criteria

I have written several VBA macros to run on an Excel spreadsheet. Inputs are entered into a table and then the macro is run. It cycles through a table of Bearings (in price ascending order) and selects the first one to pass all the criteria.

At the moment there are about 1700 rows in the table and it takes approx. 35 seconds to cycle through them all. Just wondering if there's any improvements I can make to my code to increase the efficiency. I have posted a similar question before and the code shown below has been improved since then.

Sub FindBearing() 

Dim InputWS As Worksheet

Set InputWS = Sheets("Input")



Dim CalcWS As Worksheet

Set CalcWS = Sheets("Calculations")



Dim TempWS As Worksheet

Set TempWS = ThisWorkbook.Sheets.Add            



CalcWS.Unprotect Password:="Unlock"             

Application.ScreenUpdating = False              



ClearFilters CalcWS

SetZerosToNA InputWS

OverallDimensionFilter InputWS, CalcWS

PasteFilteredTableToTempSheet TempWS, CalcWS

FindBearingFromFilteredTable TempWS, CalcWS

DeleteTempSheet TempWS

ClearFilters CalcWS

InputWS.Activate



Application.ScreenUpdating = True               

CalcWS.Protect Password:="Unlock"               





End Sub







Sub FindUnfixedBearing()                        

Dim InputWS As Worksheet

Set InputWS = Sheets("Input")



Dim CalcWS As Worksheet

Set CalcWS = Sheets("Calculations")



Dim TempWS As Worksheet

Set TempWS = ThisWorkbook.Sheets.Add



CalcWS.Unprotect Password:="Unlock"

Application.ScreenUpdating = False



ClearFilters CalcWS

SetZerosToNA InputWS

OverallDimensionFilter InputWS, CalcWS

PasteFilteredTableToTempSheet TempWS, CalcWS

FindUnfixedBearingFromFilteredTable TempWS, CalcWS

DeleteTempSheet TempWS

ClearFilters CalcWS

InputWS.Activate



Application.ScreenUpdating = True

CalcWS.Protect Password:="Unlock"





End Sub







Sub ClearFilters(ByRef CalcWS As Worksheet)        



Dim Full_Bearings_List As ListObject



If CalcWS.ListObjects("Full_Bearings_List").ShowAutoFilter Then

    CalcWS.ListObjects("Full_Bearings_List").Range.AutoFilter

End If



End Sub







Sub SetZerosToNA(ByRef InputWS As Worksheet)            



Dim x As Integer

Dim y As Integer

y = 45



For x = 31 To y

    If InputWS.Cells(x, 6).Value = 0 Then               

        InputWS.Cells(x, 6).Value = "n/a"               

    End If



Next x



End Sub







Sub OverallDimensionFilter(ByRef InputWS As Worksheet, ByRef CalcWS As Worksheet)           



If InputWS.Cells(31, 6).Value <> "n/a" And InputWS.Cells(34, 6).Value <> "n/a" Then         

    DimensionFilterTransverse1 InputWS, CalcWS



ElseIf InputWS.Cells(31, 6).Value = "n/a" And InputWS.Cells(34, 6).Value <> "n/a" Then

        DimensionFilterTransverse2 InputWS, CalcWS



ElseIf InputWS.Cells(31, 6).Value <> "n/a" And InputWS.Cells(34, 6).Value = "n/a" Then

        DimensionFilterTransverse3 InputWS, CalcWS



End If



If InputWS.Cells(32, 6).Value <> "n/a" And InputWS.Cells(35, 6).Value <> "n/a" Then         

    DimensionFilterLongitudinal1 InputWS, CalcWS



ElseIf InputWS.Cells(32, 6).Value = "n/a" And InputWS.Cells(35, 6).Value <> "n/a" Then

        DimensionFilterLongitudinal2 InputWS, CalcWS



ElseIf InputWS.Cells(32, 6).Value <> "n/a" And InputWS.Cells(35, 6).Value = "n/a" Then

        DimensionFilterLongitudinal3 InputWS, CalcWS



End If



End Sub







Sub DimensionFilterTransverse1(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)          



Sheets("Calculations").Range("X8").AutoFilter Field:=2, Criteria1:=">=" & Sheets("Input").Range("F31").Value, Operator:=xlAnd, _

Criteria2:="<=" & Sheets("Input").Range("F34").Value



End Sub







Sub DimensionFilterTransverse2(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)           



Sheets("Calculations").Range("X8").AutoFilter Field:=2, Criteria1:="<=" & Sheets("Input").Range("F34").Value



End Sub







Sub DimensionFilterTransverse3(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)          



Sheets("Calculations").Range("X8").AutoFilter Field:=2, Criteria1:=">=" & Sheets("Input").Range("F31").Value



End Sub







Sub DimensionFilterLongitudinal1(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)         



Sheets("Calculations").Range("X8").AutoFilter Field:=3, Criteria1:=">=" & Sheets("Input").Range("F32").Value, Operator:=xlAnd, _

Criteria2:="<=" & Sheets("Input").Range("F35").Value



End Sub







Sub DimensionFilterLongitudinal2(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)         







Sheets("Calculations").Range("X8").AutoFilter Field:=3, Criteria1:="<=" & Sheets("Input").Range("F35").Value



End Sub







Sub DimensionFilterLongitudinal3(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)         

Sheets("Calculations").Range("X8").AutoFilter Field:=3, Criteria1:=">=" & Sheets("Input").Range("F32").Value



End Sub







Sub PasteFilteredTableToTempSheet(ByRef TempWS As Worksheet, ByRef CalcWS As Worksheet)         



CalcWS.Activate



Dim NewTable As ListObject

Set NewTable = CalcWS.ListObjects("Full_Bearings_List")



NewTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy _

Destination:=TempWS.Range("A1")



End Sub







Sub FindBearingFromFilteredTable(ByRef TempWS As Worksheet, ByRef CalcWS As Worksheet)          



Dim i As Long

i = 1



Dim FoundBearing As Boolean

FoundBearing = False

Dim BearingArray(6) As String                                                                 



Do While Not IsEmpty(TempWS.Cells(i, 1))                                                            

    With TempWS



        BearingArray(0) = .Cells(i, 1).Value                                                    

        BearingArray(1) = .Cells(i, 2).Value

        BearingArray(2) = .Cells(i, 3).Value

        BearingArray(3) = .Cells(i, 4).Value

        BearingArray(4) = .Cells(i, 5).Value

        BearingArray(5) = .Cells(i, 6).Value

        BearingArray(6) = .Cells(i, 7).Value



    End With



    With CalcWS

        .Cells(17, 11).Value = BearingArray(0)                                                  

        .Cells(19, 15).Value = BearingArray(1)

        .Cells(20, 15).Value = BearingArray(2)

        .Cells(23, 15).Value = BearingArray(3)

        .Cells(22, 15).Value = BearingArray(4)

        .Cells(26, 15).Value = BearingArray(5)

        .Cells(17, 12).Value = BearingArray(6)



    End With



    i = i + 1                                                                                                  

    If CalcWS.Cells(17, 13).Value = "PASS" Then                                                 

        FoundBearing = True

Exit Do

    End If



Loop



If Not FoundBearing Then                                                                        

    MsgBox "No available bearing."

End If



End Sub







Sub FindUnfixedBearingFromFilteredTable(ByRef TempWS As Worksheet, ByRef CalcWS As Worksheet)           



Dim i As Long

i = 1



Dim FoundBearing As Boolean

FoundBearing = False



Dim BearingArray(6) As String



Do While Not IsEmpty(TempWS.Cells(i, 1))



    With TempWS



        BearingArray(0) = .Cells(i, 1).Value

        BearingArray(1) = .Cells(i, 2).Value

        BearingArray(2) = .Cells(i, 3).Value

        BearingArray(3) = .Cells(i, 4).Value

        BearingArray(4) = .Cells(i, 5).Value

        BearingArray(5) = .Cells(i, 6).Value

        BearingArray(6) = .Cells(i, 7).Value



    End With



    With CalcWS

        .Cells(17, 11).Value = BearingArray(0)

        .Cells(19, 15).Value = BearingArray(1)

        .Cells(20, 15).Value = BearingArray(2)

        .Cells(23, 15).Value = BearingArray(3)

        .Cells(22, 15).Value = BearingArray(4)

        .Cells(26, 15).Value = BearingArray(5)

        .Cells(17, 12).Value = BearingArray(6)



    End With



    i = i + 1



    If CalcWS.Cells(17, 13).Value = "PASS" And CalcWS.Cells(17, 14).Value = "UNFIXED" Then

        FoundBearing = True

Exit Do

    End If



Loop



If Not FoundBearing Then

    MsgBox "No available unfixed bearing."

    FindBearingFromFilteredTable TempWS, CalcWS                                                         

End If



End Sub







Sub DeleteTempSheet(ByRef TempWS As Worksheet)          



Application.DisplayAlerts = False



TempWS.Delete



Application.DisplayAlerts = True



End Sub

It seems you didn't include Option Explicit at the top of the module. You always want to do that so you ensure all your variables are declared. You can have it automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option.

Wonderfully, you have defined all your variables. Good work!

Structure

But your indenting is all.. not indented. Try to make it consistently indented so levels can be seen and labels will stick out. You have a little bit of excess white space, but I can't say that's a real problem. For instance

Sub DimensionFilterTransverse3(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)



Sheets("Calculations").Range("X8").AutoFilter Field:=2, Criteria1:=">=" & Sheets("Input").Range("F31").Value



End Sub

looks cleaner as

Sub DimensionFilterTransverse2(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)

    Sheets("Calculations").Range("X8").AutoFilter Field:=2, Criteria1:="<=" & Sheets("Input").Range("F34").Value

End Sub

ByRef

I see pretty much all of your arguments are passed ByRef. What you probably want to do is declare Functions that take arguments ByVal and return a reference you want or you don't need ByRef at all. Take this for example -

Sub DimensionFilterLongitudinal2(ByRef CalcWS As Worksheet, ByRef InputWS As Worksheet)

    Sheets("Calculations").Range("X8").AutoFilter Field:=3, Criteria1:="<=" & Sheets("Input").Range("F35").Value

End Sub

You take arguments but you don't use them. Rather you'd like to do this

Private Sub DimenstionFilterEtc(ByVal calculationRange As Range, ByVal inputRange As Range)

    calculationRange.AutoFilter field:=3, Criteria1:=">=" & inputRange.Value

End Sub

For pretty much all of your subs you pass arguments and don't use them. I think what happened is that you misunderstood how these arguments work.

Say you want to change something on Sheet1 every time. Well, you don't need to pass that as a reference to the function, the function already has access to that sheet because it's publicly available to it -

Private Sub EditSheet()

    Sheet1.ClearFormatting

end Sub

But if you wanted to use that to change different sheets, then you need the argument -

Private Sub EditSheet(ByVal targetSheet as Worksheet)

    targetSheet.ClearFormatting

end Sub

Now whatever sheet you pass will be edited, and will remain edited after the routine finishes.

Passing ByVal means that you are sending (a copy of) what it actually is as the argument. If you send it ByRef you send a it to it instead, and anything that happens to that reference carries back. For example -

Sub main()

    Dim i As Long

    i = 2

    Dim j As Long

    j = addVal(i)

    'j = 6, i = 2

    j = AddRef(i)

    'j = 4, i = 6

End Sub

Private Function addVal(ByVal i As Long) As Long

    If i > 1 Then i = i + 2

    addVal = i + 2

End Function

Private Function AddRef(ByRef i As Long) As Long

    If i > 1 Then i = i + 2

    AddRef = i + 2

End Function

Changes made ByRef stick with you after the procedure ends rather than on just a copy, leaving your original as it should be.