VBA 查找近似值

Question

我想执行一个特殊的 VLookup，其中找到的值将匹配两个条件：

发票号码必须相同
从 G 列中找到的值必须在 -100 到 100 的公差范围内

准确地说，如果发票编号“12345678”的 G 列中找到的第一个值（例如 -18,007）不符合第二个条件（例如 -18,007 + 10,000 = -8,007），则 -8,007 超出容差，所以去寻找'12345678'的下一个值，直到它符合第二个条件。这可能吗？

下面是我的脚本：

Sub MyVlookup()

    Dim lastrow As Long
    lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
    Set myrange = Range("D:G")

    For i = 2 To lastrow

        Cells(i, 10) = Application.WorksheetFunction.VLookup(Cells(i, 2), myrange, 4, False)

        'This following line is to test the value found is within the tolerance -100 to 100
        If (Cells(i, 10) + Cells(i, 1)) >= 100 Or (Cells(i, 10) + Cells(i, 1)) <= -100 Then

            Cells(i, 10).Value = "False" '<----I want to change this line to Lookup the next invoice number in Column D of table2

        Else: Cells(i, 10) = Application.WorksheetFunction.VLookup(Cells(i, 2), myrange, 4, False)

        End If

    Next i

End Sub

编辑

我想要的最终输出：

下面是使用我的修改的脚本，但需要检查：

Sub MyVlookup2()

    Dim myrange As Range
    Dim i As Long, j As Long
    Dim lastrow As Long
    Dim lastrow2 As Long  
    Dim diff As Double
    Const tolerance As Long = 100
    Set myrange = Range("D:G")
    lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
    lastrow2 = Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row

    For i = 2 To lastrow
    For j = 2 To lastrow2
         If Cells(i, 2).Value = Cells(j, 4).Value Then
            diff = Cells(i, 1).Value + Cells(j, 7).Value
               If diff <= tolerance And diff >= -tolerance Then
                  Cells(i, 9).Value = Cells(j, 4).Value
                  Cells(i, 10).Value = Cells(j, 5).Value
                  Cells(i, 11).Value = Cells(j, 6).Value
                  Cells(i, 12).Value = Cells(j, 7).Value
               Exit For
            End If
         End If
      If j = lastrow2 Then Cells(i, 10).Value = False
    Next j
    Next i

 End Sub

Answer 1

这应该可行（我决定不使用 worksheetfunction.vlookup）：

Sub MyVlookup2()

Dim myrange As Range
Dim i As Long, j As Long
Dim lastrow As Long
Dim lastrow2 As Long
Dim diff As Double
Const tolerance As Long = 100
Set myrange = Range("D:G")
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
lastrow2 = Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row

For i = 2 To lastrow
    For j = 2 To lastrow2
        If Cells(i, 2).Value = Cells(j, 4).Value Then
            diff = Cells(i, 1).Value + Cells(j, 7).Value
            If diff <= tolerance And diff >= -tolerance Then
                Cells(i, 10).Value = Cells(j, 7).Value
                Exit For
            End If
        End If
        If j = lastrow2 Then Cells(i, 10).Value = False
    Next j
Next i

End Sub

关于 Option Explicit，您应该检查 工具 > 选项... 中的复选标记，永远不要理会它再次。该行将始终自动包含在每个新模块中。

编辑

由于您更新了您的问题，如果您不更改行 If j = lastrow2 Then Cells(i, 10).Value = False，您将在未找到匹配项的地方得到空白值：

Answer 2

试试这个通用的 Alookup 代码：



Sub RegisterUDF()
Dim s As String
s = "Approximate lookup similar strings on best consecutive character match basis" & Chr(lO) & vbLf _
& "Lookup_Value = What string to lookup" & Chr(lO) & "Tbl_array = Range to find String"
Application.MacroOptions Macro:="Alookup", Description:=s, Category:=9
End Sub


Sub UnregisterUDF()
Application-MacroOptions Macro:="Alookup", Description:=Empty, Category:=Empty
End Sub


            Function Alookup(Lookup_Value As String, Tbl_Array As Range, Optional col As Integer, Optional MinCharMatch1 As Integer) As String
            'Lookup_Value = What we are searching for
            'Tbl_Array = Range in which Lookup_Value will be searched in. Ideally should be single column
            'Col = Value to the left (negative number) or right (positive number) of the Tbl_Array which would be the answer to the function. Used as offset to Lookup_Value's range in Tbl_Array. _
                   If ommitted, the best match in Tbl_Array is populated as the answer to the function
            'MinCharMatch1 = Least number of characters that should match. If ommitted, defaulted to 6
            
            Dim i As Integer, Str As String, Value As String
            Dim a As Integer, b As Integer, cell As Range
            Dim mincharmatch As Integer
            Dim rng As Range
            
            Lookup_Valuel = UCase(Replace(Lookup_Value, " ", ""))
            Lookup_Valuel = UCase(Replace(Lookup_Valuel, "-", ""))
            Lookup_Valuel = UCase(Replace(Lookup_Valuel, ":", ""))
            Lookup_Valuel = UCase(Replace(Lookup_Valuel, "/", ""))
            Lookup_Valuel = UCase(Replace(Lookup_Valuel, ",", ""))
            
            
            If MinCharMatch1 = 0 Then
            MinCharMatch1 = 6
            End If
            

                For Each cell In Tbl_Array
                cell1 = UCase(Replace(cell, " ", ""))
                cell1 = UCase(Replace(cell1, "-", ""))
                cell1 = UCase(Replace(cell1, ":", ""))
                cell1 = UCase(Replace(cell1, "/", ""))
                cell1 = UCase(Replace(cell1, ",", ""))
    
    
    
    'Check lower len in higer len
    
        If Len(cell1) < Len(Lookup_Valuel) Then
        
        mincharmatch = WorksheetFunction.Min(Len(cell1), MinCharMatch1)
          
                For j = Len(cell1) To mincharmatch Step -1
                    If InStr(Lookup_Valuel, Left(cell1, j)) > 0 Or InStr(Lookup_Valuel, Right(cell1, j)) > 0 Then
                        If Found <> "" Then
                            If j > CInt(Mid(Found, WorksheetFunction.Search("|", Found) + 1, 99)) Then
                            Found = cell.Value2 & "|" & j
                            Set rng = cell
                            End If
                        Else
                            Found = cell.Value2 & "|" & j
                            Set rng = cell
                            
                        End If
                    GoTo nextcell
                    End If
                Next j

        
        Else

         mincharmatch = WorksheetFunction.Min(Len(Lookup_Valuel), Len(cell1), MinCharMatch1)

           
                        For j = Len(Lookup_Valuel) To mincharmatch Step -1
                            If InStr(cell1, Left(Lookup_Valuel, j)) > 0 Or InStr(cell1, Right(Lookup_Valuel, j)) > 0 Then
                            
                                If Found <> "" Then
                                    If j > CInt(Mid(Found, WorksheetFunction.Search("|", Found) + 1, 99)) Then
                                    Found = cell.Value2 & "|" & j
                                    Set rng = cell
                                    End If
                                Else
                    
                                Found = cell.Value2 & "|" & j
                                Set rng = cell
                                End If
                            GoTo nextcell
                            End If
                        Next j


        End If
nextcell:
            
            Next cell
        
                    
        
            If Found <> "" Then
                If col > 0 Then
                Alookup = rng.Offset(0, col - 1).Value2
                ElseIf col < 0 Then
                Alookup = rng.Offset(0, col + 1).Value2
                Else
                Alookup = Left(Found, WorksheetFunction.Find("|", Found) - 1)
                End If
                ' Debug-Print Found
            Else
               
                Alookup = "No Match Found"
                
            End If
            
            
            
        End Function

VBA 查找近似值

VBA lookup for approximate value

vba

criteria

match

vlookup

conditional-statements