finden Match nächste Zeile mit VBA

Question

I Beispieltabelle haben, wie unten

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

Hier ist meine Unter

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 

Wie kann ich nächste Zeile mit VBA finden? Relativ- und Format benötigen genaue Übereinstimmung und für W/D/L notwendig seine nächste Übereinstimmung zurückzukehren

Beispiel: für Kautschuke, 3 Messer, 30x12x12 Eingang soll es als Ergebnis erste Zeile zurück

Answer 1

dass Nimmt man durch "am nächsten" meinst du das nächste Volumen (im Falle von keinem exaxt-Matching), schlage ich diese Funktion vor, die den richtigen Bereich für diese Parameter zurückgibt. Beachten Sie, dass ich davon ausgegangen, dass Ihre „Gauge“ Spalte „Format“ eine nächste ist (Spalten H und I, wie in Ihrem Code), während die Bilder zeigt, dass Messer letzte kommt ...

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

konnten Sie erste AutoFilter() die genauen Übereinstimmungen und dann werden die Zellen durch gefilterte Schleife zur nächsten 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 

UpdateNearest() die Funktion ein Kriterium der minimalen Quadrate Unterschiede Summe annimmt. aber Sie können sich an Ihre tatsächlichen (und unbekannten) Bedürfnisse anpassen