Страницы: 1
RSS
Вывод уникальных значений по условию в одну ячейку.
 
Здраствуйте уважаемые!
Делаю в excel что-то на подобие базы клиентов.
Есть лист обзвона, где пишется название предприятия, контактное лицо, номер телефона, о чем говорили и тд.
На другом листе делаю как бы карточку клиента:
В одной ячейке вписывается название предприятия. В другой нужно вывести все контактные лица и их телефоны этого предприятия.
Нашел такую функцию:
Код
Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, _
    Optional ByVal stringsRange As Range, Optional Delimiter As String) As String
    Dim i As Long, j As Long, criteriaMet As Boolean
     
    Set compareRange = Application.Intersect(compareRange, _
    compareRange.Parent.UsedRange)
     
    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
    stringsRange.Column - compareRange.Column)
     
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
            End If
        Next j
    Next i
    ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
End Function


На первом листе делаю дополнительный столбец в котором объединяю в одной ячейке конт.лицо и телефон.
Функция делает выборку по названию предприятия и выводит мне нужные значения в одну ячейку. Но они повторяются.

Можно ли доделать функцию чтоб выводились только уникальные значения?
Или как можно сделать это иначе?
Зарание спасибо!
 
Добавляем еще один параметр на всякий случай, если вдруг нужно или уникальные или нет иии
Код
Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, _
    Optional ByVal stringsRange As Range, Optional Delimiter As String, Optional Unical As Integer = 0) As String
    Dim i As Long, j As Long, criteriaMet As Boolean
     
    Set compareRange = Application.Intersect(compareRange, _
    compareRange.Parent.UsedRange)
     
    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
    stringsRange.Column - compareRange.Column)
     
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                If Unical = 0 Or InStr(Delimiter & ConcatIf & Delimiter, Delimiter & CStr(stringsRange.Cells(i, j)) & Delimiter) = 0 _
                    Then ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
            End If
        Next j
    Next i
    ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
End Function
Изменено: БМВ - 25.01.2020 13:19:44 (Исправил)
По вопросам из тем форума, личку не читаю.
 
БМВ, спасибо! работает.
Но объясните пожалуйста человеку не понимающему "кода" при каком значении "Unical" - что делает функция. Заметил что при любом числе выводит только уникальные значения. По Вашему сообщению я понял что можно выводить и все...
 
При нуле ( или можно не вводить ничего)
По вопросам из тем форума, личку не читаю.
 
Я собственно так и понял что при нуле, но почему-то при нуле в ячейке ничего не отображается совсем. Потому и спрашиваю :)
 
Есть в копилке тоже уже написанное, работает "из коробки":
Код
=VLOOKUPCOUPLE(B:F;1;K4;5;"
")
Изменено: Hugo - 25.01.2020 14:06:36
 
Цитата
Bitalii написал:
Потому и спрашиваю
я код менял Вы наверно успели скачать первый..
По вопросам из тем форума, личку не читаю.
 
БМВ, наверно. Вставил код заново теперь все ок. Спасибо еще раз! Хорошего дня :)
Страницы: 1
Наверх