Через 2 года вышло обновление :) Вернее вышло то уже давненько, только до темы долго подрастало :( Нужно сказать спасибо Дмитрию/The_Prist и Андрею/RAN за участие в написании этого кода (хотя они вероятно сейчас удивлены :)) В этой версии появился параметр BezPovtorov - если поставить 0, то будут выведены все повторяющиеся совпадения. Т.е. если ничего не ставить, то повторы выводиться не будут - увидите только одно значение из всех.
Function VLOOKUPCOUPLE(Table As Variant, _ SearchColumnNum As Integer, _ SearchValue As Variant, _ RezultColumnNum As Integer, _ Separator_ As String, _ Optional BezPovtorov As Boolean = True)
'Table - таблица, где ищем 'SearchColumnNum - столбец, где ищем 'SearchValue - данные, которые ищем 'RezultColumnNum - столбец, откуда берём результат 'Separator_ - разделитель, желательно вводить с пробелом в конце 'BezPovtorov - если поставить 0, то будут выведены все повторяющиеся совпадения
Dim i As Long, tmp As String, vlk
If TypeName(Table) = "Range" Then Table = Intersect(Table.Parent.UsedRange, Table).Value If BezPovtorov Then With CreateObject("Scripting.Dictionary") For i = 1 To UBound(Table) If Table(i, SearchColumnNum) = SearchValue Then tmp = Table(i, RezultColumnNum) If tmp <> "" Then If Not .Exists(tmp) Then .Add tmp, 0& vlk = vlk & Separator_ & Table(i, RezultColumnNum) End If End If End If Next i End With Else For i = 1 To UBound(Table) If Table(i, SearchColumnNum) = SearchValue Then vlk = vlk & Separator_ & Table(i, RezultColumnNum) End If Next i End If If vlk > 0 Then vlk = Mid(vlk, Len(Separator_) + 1) Else vlk = "" VLOOKUPCOUPLE = vlk End Function
Функция как и раньше работает с закрытыми книгами, только в таком случае нельзя указывать как диапазон полные столбцы. Указывайте конкретно например A1:C300, а не A:C. Если книга открыта (т.е. текущая) - то можно и A:C.
Ну и "на основе и по мотивам" можно писать другие варианты UDF, например
Function VLOOKUPCOUPLE_spec(Table As Variant, SearchColumnNum1 As Integer, SearchColumnNum2 As Integer, SearchValue As Variant, _ RezultColumnNum As Integer, Separator_ As String) 'Table - таблица, где ищем 'SearchColumnNum1/2 - столбцы, где ищем 'SearchValue - данные, которые ищем, задавать с "|" посередине 'RezultColumnNum - столбец, откуда берём результат 'Separator_ - разделитель, желательно вводить с пробелом в конце
Dim i As Long If TypeName(Table) = "Range" Then Table = Table.Value For i = 1 To UBound(Table) If Table(i, SearchColumnNum1) & "|" & Table(i, SearchColumnNum2) = SearchValue Then If VLOOKUPCOUPLE_spec <> "" Then VLOOKUPCOUPLE_spec = VLOOKUPCOUPLE_spec & Separator_ & Table(i, RezultColumnNum) Else VLOOKUPCOUPLE_spec = Table(i, RezultColumnNum) End If End If Next i If VLOOKUPCOUPLE_spec = 0 Then VLOOKUPCOUPLE_spec = "" End Function
Тут идёт сравнение по двум любым столбцам таблицы, но из лени плодить параметры и код - критерий SearchValue пишется так: D1&"|"&E1 Т.е. например: =VLOOKUPCOUPLE_spec(A1:C3;1;2;D1&"|"&E1;3;", ") или =VLOOKUPCOUPLE_spec(A1:C3;1;2;"a"&"|"&"b";3;", ") Повторы не анализируются.
Если кому нужно - можете брать за основу и модифицировать, например так (это росло из первой версии):
Function VLOOKUPCOUPLE3_spec(Table As Variant, SearchColumnNum As Integer, SearchValue As Variant, _ RezultColumnNum1 As Integer, RezultColumnNum2 As Integer, Optional Separator_dannix As String = " - ", Optional Separator_jaceek As String = "|", Optional razmer As Long = 100) As Variant 'Table - таблица, где ищем 'SearchColumnNum - столбец, где ищем 'SearchValue - данные, которые ищем 'RezultColumnNum - 2 столбца, откуда берём результат 'Separator_dannix - разделитель данных, задан " - ", но можно поменять на любой <> Separator_jaceek 'Separator_jaceek - разделитель, задан "|", но можно поменять на отсутствующий в данных!
Dim i As Long, oDict As Object, temp As String ReDim outarr(1 To 1, 1 To razmer)
For i = 1 To UBound(outarr, 2) outarr(1, i) = "" Next
If Separator_dannix = Separator_jaceek Then outarr(1, 1) = "Error! Separator_dannix = Separator_jaceek!" VLOOKUPCOUPLE3_spec = outarr Exit Function End If
Set oDict = CreateObject("Scripting.Dictionary")
Select Case TypeName(Table) Case "Range" For i = 1 To Table.Rows.Count If Table.Cells(i, SearchColumnNum) = SearchValue Then temp = Table.Cells(i, RezultColumnNum1) & Separator_dannix & Table.Cells(i, RezultColumnNum2) If temp <> "" Then If Not oDict.Exists(temp) Then oDict.Add temp, CStr(1) If VLOOKUPCOUPLE3_spec <> "" Then VLOOKUPCOUPLE3_spec = VLOOKUPCOUPLE3_spec & Separator_jaceek & temp Else VLOOKUPCOUPLE3_spec = temp End If End If End If End If Next i Case "Variant()" For i = 1 To UBound(Table) If Table(i, SearchColumnNum) = SearchValue Then temp = Table(i, RezultColumnNum1) & Separator_dannix & Table(i, RezultColumnNum2) If temp <> "" Then If Not oDict.Exists(temp) Then oDict.Add temp, CStr(1) If VLOOKUPCOUPLE3_spec <> "" Then VLOOKUPCOUPLE3_spec = VLOOKUPCOUPLE3_spec & Separator_jaceek & temp Else VLOOKUPCOUPLE3_spec = temp End If End If End If End If Next i End Select
Dim tempArr tempArr = Split(VLOOKUPCOUPLE3_spec, Separator_jaceek)
If (UBound(tempArr) + 1) > UBound(outarr, 2) Then outarr(1, 1) = "Error! Не хватает места для данных!" VLOOKUPCOUPLE3_spec = outarr Exit Function End If
For i = 0 To UBound(tempArr) outarr(1, i + 1) = tempArr(i) Next
VLOOKUPCOUPLE3_spec = outarr End Function
Массивная, результат берётся из двух колонок. Тянет данные и из закрытой книги. Причём все - и критерий, и данные. Но конечно уникальные критерии нужно предварительно вытянуть отдельной процедурой. Или массивной UDF :) По умолчанию задал размер массива формулы на 100 ячеек - если нужно больше, то нужно указать в параметре. Ну и если так много не нужно - стОит указать столько, сколько используете - будет быстрее шевелиться. Разделители и размер заданы по умолчанию, но можно задать свои.