UDF VLOOKUPCOUPLE() - В продолжение темы "Сцепить данные в столбце по условию повторения данных в соседнем."
Через 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 ячеек - если нужно больше, то нужно указать в параметре.
Ну и если так много не нужно - стОит указать столько, сколько используете - будет быстрее шевелиться.
Разделители и размер заданы по умолчанию, но можно задать свои.
Что именно делает в деталях - нужно вспоминать, но всё есть в теме
Там и файл
Хотя вероятно не пригодилось, раз prosmith не отписался... :(
Через 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 ячеек - если нужно больше, то нужно указать в параметре.
Ну и если так много не нужно - стОит указать столько, сколько используете - будет быстрее шевелиться.
Разделители и размер заданы по умолчанию, но можно задать свои.
Что именно делает в деталях - нужно вспоминать, но всё есть в теме
Там и файл
Хотя вероятно не пригодилось, раз prosmith не отписался... :(
