2
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ I'd repeat the very same suggestions as before \$\endgroup\$ – user3598756 Jul 26 '16 at 11:21
0
\$\begingroup\$

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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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