使用多个条件在二维数组中搜索值-解网

问：

假设我有下表，有三列。我想从 Column3 中搜索完全匹配或下一个上一个日期，条件是 Column1 是给定值。

这可以通过 XLOOKUP 轻松完成。但是，我需要在 VBA 中执行此操作，因为我将向用户显示在用户窗体文本框中找到的日期。从我到目前为止搜索的内容来看，不适用于多个条件，因此解决方案将涉及操作数组。Application.Worksheetfunction.Xlookup&

我从该表创建了一个变体，内容如下：

Dim TBL As ListObject
Set TBL = Sheets("sheet1").ListObjects("Table1")
Dim DirArray As Variant
DirArray = TBL.DataBodyRange

关于如何使用数组获得近似匹配的任何建议？

数组 Excel VBA 多维数组匹配

可能有一个更简洁的答案，但这里有一个简单的蛮力函数，它只是扫描给定数据中的每一行，寻找与给定条件最接近的匹配项。该函数返回最接近匹配项的日期，但如果它返回最接近匹配项的行号，也许对您更有用。例如，将此函数放在新的代码模块中，以便可以将其作为单元格中的函数调用=findEntryByCol1andCol3(Table1,F1,F2)

Option Explicit

Public Function findEntryByCol1andCol3(dataToSearch As Range, findCol1, findCol3) As Variant

    '// variable to hold the row with the closest match to criteria
    Dim matchRow As Range
    Set matchRow = Nothing
    
    '// variable to hold the row being checked
    Dim checkRow As Range
    
    Dim ix As Long
    For ix = 1 To dataToSearch.Rows.Count
        '// get the next row to be checked
        Set checkRow = dataToSearch.Rows(ix)
                
        '// does column 1 in this row match the search criterion for column 1?
        If checkRow.Cells(1, 1).Value = findCol1 Then
            
            '// now see if the date in the row is less than the search date
            If findCol3 >= checkRow.Cells(1, 3).Value Then
                
                '// If there has been no match then use this checked row as the first found match
                If matchRow Is Nothing Then
                    Set matchRow = checkRow
                    
                '// If there has been a previous match check
                '// if the new date is later that the previously found date
                ElseIf matchRow.Cells(1, 3).Value < checkRow.Cells(1, 3).Value Then
                    
                    Set matchRow = checkRow
                    
                End If
            End If
        Else
        
        End If
        
    Next ix
    
    '// Now return the result of the search
    If matchRow Is Nothing Then
        findEntryByCol1andCol3 = "Not found"
    Else
        findEntryByCol1andCol3 = matchRow.Cells(1, 3)
    End If
    
    
End Function

1赞 Ike 1/9/2023 #2

使用值数组将比为每个检查引用单元格更快 - 特别是如果你的表要大得多。

您可以使用此函数 - 如果找不到有效日期，它将返回 0。

正如我正在使用的那样，您将需要 Excel 365 才能正常工作。sortBy

通过使用 SortBy，如果我们找到匹配的日期，退出 for 循环是安全的。

Public Function nearestDate(lo As ListObject, valueColumn1 As String, valueColumn3 As Date) As Date

Dim arrValues As Variant
arrValues = Application.WorksheetFunction.SortBy(lo.DataBodyRange, lo.ListColumns(1).DataBodyRange, 1, lo.ListColumns(3).DataBodyRange, 1)

Dim i As Long
For i = 1 To UBound(arrValues, 1)
    If arrValues(i, 1) = valueColumn1 Then
        If arrValues(i, 3) = valueColumn3 Then
            'we found what we are looking for
            nearestDate = arrValues(i, 3)
        ElseIf arrValues(i, 3) < valueColumn3 Then
            'we have to check next row - if there is one
            If i < UBound(arrValues, 1) Then
                If arrValues(i + 1, 1) = valueColumn1 And arrValues(i + 1, 3) > valueColumn3 Then
                    'same column1 but column3 greater than valueColumn3
                    nearestDate = arrValues(i, 3)
                ElseIf arrValues(i + 1, 1) <> valueColumn1 Then
                    'new column1 value --> therefore we take current date
                    nearestDate = arrValues(i, 3)
                End If
            Else
                'last value --> ok
                nearestDate = arrValues(i, 3)
            End If
        End If
    End If
    
    If nearestDate > 0 Then Exit For
Next

End Function

您可以像这样调用此函数：

Public Sub test()
Dim ws As Worksheet: Set ws = Thisworkbook.Worksheets("sheet1")

Dim lo As ListObject: Set lo = ws.ListObjects("Table1")
Dim valueColumn1 As String: valueColumn1 = ws.Range("F1")
Dim valueColumn3 As Date: valueColumn3 = ws.Range("F2")

Debug.Print nearestDate(lo, valueColumn1, valueColumn3)

End Sub

上一个：匹配以在列表中查找日期会根据日期的格式产生不同的答案

下一个：这里的类型匹配是什么？

使用多个条件在二维数组中搜索值

Search values in a two dimensional array with multiple criteria

评论