Предположим, у меня есть следующая таблица с тремя столбцами. Я хочу найти точное совпадение или следующую предыдущую дату из столбца 3, при условии, что столбец 1 является заданным значением.
Это можно легко сделать с помощью XLOOKUP. Однако мне нужно сделать это в VBA, потому что я покажу пользователю дату, найденную в текстовом поле пользовательской формы. Из того, что я искал до сих пор, Application.Worksheetfunction.Xlookup
не будет работать с &
для нескольких критериев, поэтому решение для этого будет включать манипулирование массивами.
Я создал вариант из этой таблицы, написав:
Dim TBL As ListObject
Set TBL = Sheets("sheet1").ListObjects("Table1")
Dim DirArray As Variant
DirArray = TBL.DataBodyRange
Любые советы о том, как получить это приблизительное совпадение с помощью массивов?
Вполне может быть более аккуратный ответ, но вот простая функция грубой силы, которая просто сканирует каждую строку в заданных данных в поисках наиболее близкого соответствия заданным критериям. Функция возвращает дату ближайшего совпадения, но, возможно, было бы полезнее, если бы она возвращала, скажем, номер строки, которая является ближайшим совпадением. Поместите эту функцию в новый модуль кода, чтобы ее можно было вызывать как функцию из ячейки, например =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
Использование массива значений будет быстрее, чем обращение к ячейке для каждой проверки — особенно. если ваш стол намного больше.
Вы можете использовать эту функцию — она вернет 0, если действительная дата не найдена.
Поскольку я использую sortBy
, вам понадобится Excel 365, чтобы это работало.
Используя 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