Lost your password?


Хитрости »
Основные понятия (25)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (18)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (67)
Разное (42)
Баги и глюки Excel (4)

Как сцепить несколько значений в одну ячейку по критерию? СцепитьЕсли

Все чаще вижу на разных форумах вопросы типа: Есть таблица, в одном столбце фамилии, в другом оценки(виды работ и т.д.). Как сцепить в одной ячейке для каждой фамилии только принадлежащие ей оценки? Стандартными функциями это сделать весьма проблематично, т.к. заранее неизвестно сколько будет этих оценок и фамилий. Или собрать в одну ячейку через запятую фамилии всех сотрудников одного отдела, но все сотрудники идут вразнобой. Т.е. из такой таблицы:
Исходная таблица
Получить такую:
Результат

Вот и решил написать небольшую функцию пользователя на VBA, которая решает данную проблему. Так же подобную функцию называют "многоразовый ВПР", потому что она по критерию возвращает ВСЕ значения для этого критерия, а не только первое.

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          http://www.excel-vba.ru
' Purpose:
'---------------------------------------------------------------------------------------
Function СцепитьЕсли(ByRef Диапазон As Range, ByVal Критерий As String, ByRef Диапазон_сцепления As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False) As String
    Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long
    If Диапазон.Count > 1 Then
        avDateArr = Intersect(Диапазон, Диапазон.Parent.UsedRange).Value
        avRezArr = Intersect(Диапазон_сцепления, Диапазон_сцепления.Parent.UsedRange).Value
        If Диапазон.Rows.Count = 1 Then
            avDateArr = Application.Transpose(avDateArr)
            avRezArr = Application.Transpose(avRezArr)
        End If
    Else
        ReDim avDateArr(1, 1): ReDim avRezArr(1, 1)
        avDateArr(1, 1) = Диапазон.Value
        avRezArr(1, 1) = Диапазон_сцепления.Value
    End If
    lUBnd = UBound(avDateArr, 1)
    'Определяем вхождение операторов сравнения в Критерий
    Dim objRegExp As Object, objMatches As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = False: objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<"
    Set objMatches = objRegExp.Execute(Критерий)
    'Если есть вхождения
    If objMatches.Count > 0 Then
        Dim sStrMatch As String
        sStrMatch = objMatches.Item(0)
        Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
        If IsNumeric(Критерий) And Критерий <> "" Then
            Критерий = CDbl(Критерий)
        End If
        Select Case sStrMatch
        Case "="
            For li = 1 To lUBnd
                If avDateArr(li, 1) = Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<>"
            For li = 1 To lUBnd
                If avDateArr(li, 1) <> Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case ">=", "=>"
            For li = 1 To lUBnd
                If avDateArr(li, 1) >= Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<=", "=<"
            For li = 1 To lUBnd
                If avDateArr(li, 1) <= Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case ">"
            For li = 1 To lUBnd
                If avDateArr(li, 1) > Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<"
            For li = 1 To lUBnd
                If avDateArr(li, 1) < Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        End Select
    Else    'Если нет вхождения
        For li = 1 To lUBnd
            If avDateArr(li, 1) Like Критерий Then
                If Trim(avRezArr(li, 1)) <> "" Then _
                   sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
            End If
        Next li
    End If
 
    If БезПовторов Then
        Dim oDict As Object, sTmpStr
        Set oDict = CreateObject("Scripting.Dictionary")
        sTmpStr = Split(sStr, Разделитель)
        On Error Resume Next
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            oDict.Add sTmpStr(li), sTmpStr(li)
        Next li
        sStr = ""
        sTmpStr = oDict.keys
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            sStr = sStr & IIf(sStr <> "", Разделитель, "") & sTmpStr(li)
        Next li
    End If
    СцепитьЕсли = sStr
End Function

Для применения функции в своем файле достаточно создать стандартный модуль (о том как создать стандартный модуль: Что такое модуль? Какие бывают модули?) и просто вставить приведенный код. После этого в диспетчере функций появиться новая категория (если до этого её не было) - Определенные пользователем (User Defined). В ней эта функция - СцепитьЕсли.
Синтаксис:
=СцепитьЕсли(B5:B18;B5;C5:C18;"-";0)

По принципу работы функция похожа на стандартную СУММЕСЛИ. Указывается диапазон значений(где просматривать значение), критерий и диапазон значений для сцепления. Символ для разделения слов указывать необязательно.

Диапазон(B5:B18) - диапазон, в котором искать критерий(указывается один столбец)

Критерий(B5) - критерий. Значение, на основании которого необходимо сцеплять значения. Может содержать символы подстановки - * и ? и символы сравнения (<>"", <23, >0, "<>"&A1 и т.п.). Просматривается Диапазон. При совпадении значения ячейки в Диапазоне значение из Диапазона_Сцепления добавляется к результату с выбранным разделителем.

Диапазон_сцепления(C5:C18) - из этого диапазона берется значение для сцепления, если значение в аргументе Диапазон совпадает с аргументом Критерий(указывается один столбец). Если в Диапазоне значение 5-ой строки совпадает с критерием, то из Диапазона_Сцепления будет взято так же значение из 5-ой строк этого диапазона и сцеплено с результатом.

Разделитель("-") - По умолчанию пробел, но можно задать любой другой символ или группу символов.

БезПовторов - если указать 1 или ИСТИНА, то в результате получится строка, в которой нет одинаковых значений. Если указать 0 или ЛОЖЬ, то будут выведены все значения. По умолчанию значение ЛОЖЬ.

Примечание: для работы функции должны быть разрешены макросы

Скачать пример

  Пример СцепитьЕсли.xls (68,0 KiB, 13 477 скачиваний)

Также см.:
ВПР_МН
Сцепить_МН
СцепитьЕсли
Что такое функция пользователя(UDF)?
ВПР с возвратом всех значений


Статья помогла? Поделись ссылкой с друзьями!
  Плейлист   Видеоуроки

Поиск по меткам

Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистика
Обсуждение: 86 комментариев
  1. Юлия:

    Огромное Спасибо!!!!!!!!!! Функция супер просто!!!!!!!!!!!

  2. Ирина:

    Вы пишете-----Для применения функции в своем файле достаточно создать стандартный модуль(как это сделать написано здесь) и просто вставить приведенный код. После этого в диспетчере функций появиться новая категория(если до этого её не было) – Определенные пользователем. В ней эта функция – СцепитьЕсли.-----

    А новая функция не появляется в диспетчере функций. И куда именно ставить код, ведь в форме пользователя ее не поставить.Так я поставила в модуль листа. Или я что-то не так сделала.Подскажите. Эта проблема мучает не один день :-)

  3. Ирина :

    достаточно создать стандартный модуль(как это сделать написано здесь) и просто вставить приведенный код

    А новая функция не появляется в диспетчере функций. И куда именно ставить код, ведь в форме пользователя ее не поставить.Так я поставила в модуль листа. Или я что-то не так сделала.

    Конечно неверно сделали. Я ведь даже ссылки в статье активные сделал, чтобы можно было на соответствующую статью перейти и почитать - не поленитесь, зайдите и почитайте что такое стандартный модуль и как его создать. И в стандартном модуле запишите данный код. Так же можно скачать пример файла с данной функцией и посмотреть, где там записан код.

  4. Ирина:

    Sorry! Действительно все работает, нужно только внимательно читать. Спасибо, функция работает как часы, даже интересно стало работать на Excelе, а была бы эта функция стандартной, то использовали бы ее, особо не вникая в подробности.

  5. Александр:

    Здравствуйте. А скажите пожалуйста возможно ли вывод 2-х отдельных Диапазонов_сцепления, один из которых будет постоянным, например
    получено от Иванова - ххх руб., от Петрова - ххх руб., и т.д. (ФИО - постоянные составляющие из 1-го диапазона, ххх - меняющиеся значения из 2-го диапазона). Заранее благодарен. Александр.

  6. Валентин:

    Здравствуйте, классная формула, а как ее усовершенствовать,чтобы она сцепляла по 2 критериям. Помогите пожалуйста.Оченьнадо. И данные могла брать с разныъх листов

  7. Для добавления второго условия дописать еще один критерий к аргументам функции:

    ByVal Критерий2 As String

    и в коде у каждого условия дописать сравнение с ним:

    If avDateArr(li, 1) = Критерий And avDateArr(li, 1) = Критерий2 Then
    • Татьяна:

      Дмитрий, я добавила второй критерий. так как Вы написали, но когда добавляю новый критерий в формулу, выдает ошибку. может нужно в отображение формулы sStr = sStr & IIf(sStr "", Ðàçäåëèòåëü, "") & avRezArr(li, 1) добавить этот второй критерий или я что-то не понимаю. Спасибо

      • Татьяна, не знаю, Вам виднее. Я показал направление - что у Вас за ошибка и что именно и куда Вы добавили - я не знаю...
        Если добавить все правильно - то ошибок быть не должно.

        • Татьяна:

          Спасибо за ответ. Добавила я все правильно. я хотела сказать, что добавление того, что Вы написали недостаточно для включения второго критерия

  8. Николай:

    Такой вопрос, функция круто работает, но можно ли найденные значения сразу суммировать?

  9. Николай - нет. Это же функция для текста. Для суммирования как раз СУММЕСЛИ.

  10. Елена:

    Здравствуйте, помогоите сцепить ячейку с датой и текстовую ячейку. У меня вместо даты в сцепленном варианте получается 5-ти значное число

Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти
Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2021 Excel для всех   Войти