Через 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 ячеек - если нужно больше, то нужно указать в параметре. Ну и если так много не нужно - стОит указать столько, сколько используете - будет быстрее шевелиться. Разделители и размер заданы по умолчанию, но можно задать свои.
Достиг порога - после 17-го сообщения не могу зайти на "OFF: Порог работоспособности форума new"... :( Все темы, где 17+ - недоступны. Раз там написать не могу - пишу тут :) Можете удалить...
Столкнулся с непонятной ошибкой после перехода с 2000 на 2003 Эксель. Есть файл с кодом, код древний, но прекрасно работал. Вот такая строка, заносит формулу в ячейку: Selection.Offset(0, 12).Formula = "=H" & oneeur & "*" & cureur & "+H" & onelvl & "+H" & oneusd & "*" & curusd перестала работать, выпадает в ошибку, в errorhandler:
--------------------------- Microsoft Visual Basic --------------------------- Run-time error '1004':
Application-defined or object-defined error --------------------------- OK Help ---------------------------
Причём чуть выше строка Selection.Offset(0, 7).Formula = "=SUM(H" & one & ":H" & two & ")" продолжает работать.
Формат ячеек роли не играет, т.е. при текстовом заносит строку, при других вылетает. Если Пока залатался так, но это уже не то, не видно, что из чего получили:
Не могу найти, как кодом определить, какое положение у юзера с этим крыжиком, чтоб потом назад вернуть. А то после отработки макроса положение остаётся, как в макросе, а надо бы вернуть взад... Никто не задавался вопросом?
Что-то форум глюканул, тема пропала, а до этого мне в неё писать не давал, говорил - сперва зарегистрируйся... хотя я и так уже...
В общем, расту, мой код от кода The_Prist отличался только Long/Integer и тем, что The_Prist лишнюю переменную забыл убрать. Ну и ещё я VLOOKUPCOUPLE2 писал, вот этими двойками :)
Итог такой (мой вариант):
Function VLOOKUPCOUPLE(Table As Variant, SearchColumnNum As Integer, SearchValue As Variant, _ RezultColumnNum As Integer, Separator_ As String) 'Table - таблица, где ищем 'SearchColumnNum - столбец, где ищем 'SearchValue - данные, которые ищем 'RezultColumnNum - колонка, откуда берём результат 'Separator_ - разделитель, желательно вводить с пробелом в конце
Dim i As Integer
Select Case TypeName(Table) Case "Range" For i = 1 To Table.Rows.Count If Table.Cells(i, SearchColumnNum) = SearchValue Then If VLOOKUPCOUPLE <> "" Then VLOOKUPCOUPLE = VLOOKUPCOUPLE & Separator_ & Table.Cells(i, RezultColumnNum) Else VLOOKUPCOUPLE = Table.Cells(i, RezultColumnNum) End If End If Next i Case "Variant()" For i = 1 To UBound(Table) If Table(i, SearchColumnNum) = SearchValue Then If VLOOKUPCOUPLE <> "" Then VLOOKUPCOUPLE = VLOOKUPCOUPLE & Separator_ & Table(i, RezultColumnNum) Else VLOOKUPCOUPLE = Table(i, RezultColumnNum) End If End If Next i
End Select If VLOOKUPCOUPLE = 0 Then VLOOKUPCOUPLE = "" End Function
Раз тут рядом пошёл разговор про тонкости настройки Excel, хочу спросить - на моей машине заглавие окна - "Microsoft Excel - test.xls", рядом - "Microsoft Excel - test" Из-этого пришлось скрипт править для коллеги, окно не находил... Искал - так и не понял, почему разница и где настраивается.