Search values in a two dimensional array with multiple criteria-CodePudding

Suppose I have the following table with three columns. I want to search for an exact match or next previous date from Column3, conditional to Column1 being a given value.

This can be easily done with XLOOKUP. However, I need to do so in VBA because I'll show the date found in a userform Textbox to the user. From what I have searched so far, Application.Worksheetfunction.Xlookup won't work with an & for multiple criteria, so the solution for this would involve manipulating arrays.

I created a variant from that table by writing:

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

Any advice on how to get that approximate match using arrays?

CodePudding user response：

Using an array of values will be faster than referencing a cell for each check - esp. if your table is much larger.

You can use this function - it will return 0 in case no valid date is found.

As I am using sortBy you will need Excel 365 for this to work.

By using SortBy it is safe to exit the for-loop in case we have found a matching date.

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

You can call this function like this:

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

CodePudding user response：

There may well be a neater answer, but here is a simple brute-force function that just scans down every row in the given data looking for the closest match to the given criteria. The function returns the date of the closest match, but maybe it would be more useful to you if it returned, say, the row number of the row that is the closest match. Put this function in a new code module so that it can be called as a function from a cell, for example =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