Question

我有样本表，如下所示

Type    Format  W   D   L   Gauge
Roxy    Rubbers 31  1   1   3
Roxy    Rubbers 36  0   48  4
Roxy    Rubbers 36  1   1   3

这是我的潜艇

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

如何使用VBA找到最近的行？量表和格式需要精确匹配，W / D / L需要返回最接近的匹配

实施例：对于橡胶，3规格，30x12x12输入，它应该返回第一行

Answer 1

假设“最近”表示最接近的音量（在没有exaxt匹配的情况下），我建议这个函数返回给定参数的正确范围。请注意，我假设您的“Gauge”列位于“Format”列旁边（代码中的H列和I列），而您的图片显示该量表是最后一个...

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

您可以先AutoFilter()完全匹配，然后循环过滤最近的三元组：

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

UpdateNearest()函数假设最小差异平方和的标准。但你可以适应你的实际（和未知）需求

使用VBA查找最近的行匹配

2 个答案: