Cycle through a table to find the cheapest bearing that passes











up vote
2
down vote

favorite












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









share|improve this question
















bumped to the homepage by Community 13 mins ago


This question has answers that may be good or bad; the system has marked it active so that they can be reviewed.















  • I'd repeat the very same suggestions as before
    – user3598756
    Jul 26 '16 at 11:21















up vote
2
down vote

favorite












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









share|improve this question
















bumped to the homepage by Community 13 mins ago


This question has answers that may be good or bad; the system has marked it active so that they can be reviewed.















  • I'd repeat the very same suggestions as before
    – user3598756
    Jul 26 '16 at 11:21













up vote
2
down vote

favorite









up vote
2
down vote

favorite











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









share|improve this question















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






performance vba excel






share|improve this question















share|improve this question













share|improve this question




share|improve this question








edited Mar 20 at 23:46









Raystafarian

5,8141048




5,8141048










asked Jul 26 '16 at 9:46









Robin

484




484





bumped to the homepage by Community 13 mins ago


This question has answers that may be good or bad; the system has marked it active so that they can be reviewed.







bumped to the homepage by Community 13 mins ago


This question has answers that may be good or bad; the system has marked it active so that they can be reviewed.














  • I'd repeat the very same suggestions as before
    – user3598756
    Jul 26 '16 at 11:21


















  • I'd repeat the very same suggestions as before
    – user3598756
    Jul 26 '16 at 11:21
















I'd repeat the very same suggestions as before
– user3598756
Jul 26 '16 at 11:21




I'd repeat the very same suggestions as before
– user3598756
Jul 26 '16 at 11:21










1 Answer
1






active

oldest

votes

















up vote
0
down vote













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.






share|improve this answer





















    Your Answer





    StackExchange.ifUsing("editor", function () {
    return StackExchange.using("mathjaxEditing", function () {
    StackExchange.MarkdownEditor.creationCallbacks.add(function (editor, postfix) {
    StackExchange.mathjaxEditing.prepareWmdForMathJax(editor, postfix, [["\$", "\$"]]);
    });
    });
    }, "mathjax-editing");

    StackExchange.ifUsing("editor", function () {
    StackExchange.using("externalEditor", function () {
    StackExchange.using("snippets", function () {
    StackExchange.snippets.init();
    });
    });
    }, "code-snippets");

    StackExchange.ready(function() {
    var channelOptions = {
    tags: "".split(" "),
    id: "196"
    };
    initTagRenderer("".split(" "), "".split(" "), channelOptions);

    StackExchange.using("externalEditor", function() {
    // Have to fire editor after snippets, if snippets enabled
    if (StackExchange.settings.snippets.snippetsEnabled) {
    StackExchange.using("snippets", function() {
    createEditor();
    });
    }
    else {
    createEditor();
    }
    });

    function createEditor() {
    StackExchange.prepareEditor({
    heartbeatType: 'answer',
    convertImagesToLinks: false,
    noModals: true,
    showLowRepImageUploadWarning: true,
    reputationToPostImages: null,
    bindNavPrevention: true,
    postfix: "",
    imageUploader: {
    brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
    contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
    allowUrls: true
    },
    onDemand: true,
    discardSelector: ".discard-answer"
    ,immediatelyShowMarkdownHelp:true
    });


    }
    });














    draft saved

    draft discarded


















    StackExchange.ready(
    function () {
    StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fcodereview.stackexchange.com%2fquestions%2f135942%2fcycle-through-a-table-to-find-the-cheapest-bearing-that-passes%23new-answer', 'question_page');
    }
    );

    Post as a guest















    Required, but never shown

























    1 Answer
    1






    active

    oldest

    votes








    1 Answer
    1






    active

    oldest

    votes









    active

    oldest

    votes






    active

    oldest

    votes








    up vote
    0
    down vote













    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.






    share|improve this answer

























      up vote
      0
      down vote













      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.






      share|improve this answer























        up vote
        0
        down vote










        up vote
        0
        down vote









        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.






        share|improve this answer












        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.







        share|improve this answer












        share|improve this answer



        share|improve this answer










        answered Mar 21 at 0:05









        Raystafarian

        5,8141048




        5,8141048






























            draft saved

            draft discarded




















































            Thanks for contributing an answer to Code Review Stack Exchange!


            • Please be sure to answer the question. Provide details and share your research!

            But avoid



            • Asking for help, clarification, or responding to other answers.

            • Making statements based on opinion; back them up with references or personal experience.


            Use MathJax to format equations. MathJax reference.


            To learn more, see our tips on writing great answers.





            Some of your past answers have not been well-received, and you're in danger of being blocked from answering.


            Please pay close attention to the following guidance:


            • Please be sure to answer the question. Provide details and share your research!

            But avoid



            • Asking for help, clarification, or responding to other answers.

            • Making statements based on opinion; back them up with references or personal experience.


            To learn more, see our tips on writing great answers.




            draft saved


            draft discarded














            StackExchange.ready(
            function () {
            StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fcodereview.stackexchange.com%2fquestions%2f135942%2fcycle-through-a-table-to-find-the-cheapest-bearing-that-passes%23new-answer', 'question_page');
            }
            );

            Post as a guest















            Required, but never shown





















































            Required, but never shown














            Required, but never shown












            Required, but never shown







            Required, but never shown

































            Required, but never shown














            Required, but never shown












            Required, but never shown







            Required, but never shown







            Popular posts from this blog

            404 Error Contact Form 7 ajax form submitting

            How to know if a Active Directory user can login interactively

            TypeError: fit_transform() missing 1 required positional argument: 'X'