Find nearest row match using VBA - vba

Question

I have sample table as below
Type Format W D L Gauge
Roxy Rubbers 31 1 1 3
Roxy Rubbers 36 0 48 4
Roxy Rubbers 36 1 1 3
Here is my sub
Sub Calculate()
Dim Format, Gauge, Width, Depth, Length As String
Format = Sheets("inputs").Range("H26")
Gauge = Sheets("inputs").Range("I26")
Width = Sheets("inputs").Range("J26")
Depth = Sheets("inputs").Range("K26")
Length = Sheets("inputs").Range("L26")
Dim vArray() As Variant
vArray = Range("myRange")
Dim i As Long
For i = LBound(vArray, 1) To UBound(vArray, 1)
Debug.Print vArray(i, 1)
Next
End Sub
How do I find nearest row using VBA?
Gauge and format needs to be exact match and for W/D/L need to return nearest match
Example:
For Rubbers, 3 gauge, 30x12x12 input it should return first row as result

Answer 1

Assuming that by "nearest" you meant nearest volume (in the case of no exaxt matching), I suggest this function that returns the right range given those parameters. Note that I assumed that your "Gauge" column is next to the "Format" one (columns H and I as in your code) while your pictures shows that gauge comes last...
Option Explicit
Function findNearestRow(FindIn As Range, Format As String, _
Gauge As String, Width As Double, Depth As Double, Length As Double) As Range
Dim F As String, G As String, W As Double, D As Double, L As Double
Dim i As Long, best As Long, vol As Double, diff As Double, minDiff As Double
minDiff = 99999999
vol = Width * Depth * Length
For i = 1 To FindIn.Rows.Count
F = FindIn.Cells(i, 1).Value
G = FindIn.Cells(i, 2).Value
If F = Format And G = Gauge Then
W = FindIn.Cells(i, 3).Value
D = FindIn.Cells(i, 4).Value
L = FindIn.Cells(i, 5).Value
If W = Width And D = Depth And L = Length Then
Set findNearestRow = FindIn.Rows(i)
Exit Function
End If
diff = Abs(W * D * L - vol)
If diff < minDiff Then
minDiff = diff
best = i
End If
End If
Next
If minDiff < 1000 Then Set findNearestRow = FindIn.Rows(best)
' Else it returns null, nearest matching too far
End Function
Sub Test()
Dim r As Range
Set r = findNearestRow(FindIn:=Range("H2:L20"), _
Format:=Sheets("inputs").Range("H26"), _
Gauge:=Sheets("inputs").Range("I26"), _
Width:=Sheets("inputs").Range("J26"), _
Depth:=Sheets("inputs").Range("K26"), _
Length:=Sheets("inputs").Range("L26"))
If r Is Nothing Then
MsgBox "no matching found"
Else
r.Select
End If
End Sub

Answer 2

You could first AutoFilter() the exact matches and then loop through filtered cells for the nearest triple:
Option Explicit
Sub Calculate()
Dim Format As String
Dim Gauge As Long, Width As Long, Depth As Long, Length As Long
Dim nearestRate As Double
Dim nearestRng As Range, cell As Range
With Sheets("inputs")
Format = .Range("H26").Value2
Gauge = .Range("I26").Value2
Width = .Range("J26").Value2
Depth = .Range("K26").Value2
Length = .Range("L26").Value2
With .Range("F1", .Cells(.Rows.Count, "A").End(xlUp))
.AutoFilter field:=2, Criteria1:=Format
.AutoFilter field:=6, Criteria1:=Gauge
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then
nearestRate = 100000000#
For Each cell In .Resize(.Rows.Count - 1, 1).Offset(1, 2).SpecialCells(xlCellTypeVisible)
UpdateNearest cell, Width, Depth, Length, nearestRate, nearestRng
Next
End If
End With
End With
End Sub
Function UpdateNearest(rng As Range, refVal1 As Long, refVal2 As Long, refVal3 As Long, nearestRate As Double, nearestRng As Range) As Long
Dim rate As Double
rate = Sqr((rng.Value - refVal1) ^ 2 + (rng.Offset(, 1).Value - refVal1) ^ 2 + (rng.Offset(, 2).Value - refVal2) ^ 2)
If rate < nearestRate Then
nearestRate = rate
Set nearestRng = rng
End If
End Function
the UpdateNearest() function assumes a criteria of minimum differences squares sum. but you can adapt to your actual (and unknown) needs