Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
UDF VLOOKUPCOUPLE() - В продолжение "Сцепить данные в столбце по условию ..."
 
UDF VLOOKUPCOUPLE() - В продолжение темы "Сцепить данные в столбце по условию повторения данных в соседнем."  
http://www.planetaexcel.ru/forum.php?thread_id=16564  
 
Через 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 ячеек - если нужно больше, то нужно указать в параметре.  
Ну и если так много не нужно - стОит указать столько, сколько используете - будет быстрее шевелиться.  
Разделители и размер заданы по умолчанию, но можно задать свои.  
 
Что именно делает в деталях - нужно вспоминать, но всё есть в теме    
http://www.planetaexcel.ru/forum.php?thread_id=40793&page_forum=2&allnum_forum=18  
Там и файл http://www.planetaexcel.ru/docs/forum_upload/post_330336.xls  
Хотя вероятно не пригодилось, раз prosmith не отписался... :(
off на off
 
Достиг порога - после 17-го сообщения не могу зайти на "OFF: Порог работоспособности форума new"... :(  
Все темы, где 17+ - недоступны.  
Раз там написать не могу - пишу тут :)  
Можете удалить...
Непонятная ошибка макроса после перехода с 2000 на 2003 Эксель
 
Столкнулся с непонятной ошибкой после перехода с 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 & ")"  
продолжает работать.  
 
Формат ячеек роли не играет, т.е. при текстовом заносит строку, при других вылетает.  
Если  
Пока залатался так, но это уже не то, не видно, что из чего получили:  
 
ttt = Range("H" & oneeur).Value * cureur + Range("H" & onelvl).Value + Range("H" & oneusd).Value * curusd  
Selection.Offset(0, 12).Value = ttt  
 
Потестите, кому не лень - закомментированная строка отработает под 2003?  
 
Sub tt()  
oneeur = 1  
onelvl = 2  
oneusd = 3  
cureur = 0.222  
curusd = 0.333  
 
ttt = Range("H" & oneeur).Value * cureur + Range("H" & onelvl).Value + Range("H" & oneusd).Value * curusd  
Selection.Offset(0, 12).Value = ttt  
'Selection.Offset(0, 12).Formula = "=H" & oneeur & "*" & cureur & "+H" & onelvl & "+H" & oneusd & "*" & curusd  
End Sub
Find xlWhole или xlPart ?
 
Не могу найти, как кодом определить, какое положение у юзера с этим крыжиком, чтоб потом назад вернуть. А то после отработки макроса положение остаётся, как в макросе, а надо бы вернуть взад...  
Никто не задавался вопросом?
VLOOKUPCOUPLE()
 
Что-то форум глюканул, тема пропала, а до этого мне в неё писать не давал, говорил - сперва зарегистрируйся... хотя я и так уже...  
 
В общем, расту, мой код от кода 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"  
Из-этого пришлось скрипт править для коллеги, окно не находил... Искал - так и не понял, почему разница и где настраивается.
Страницы: 1
Наверх