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. Павел:

    С П А С И Б О!!!
    я уж думал сам запариться над макросом....но вот наткнулся на эту реализацию.
    5+

  2. Денис:

    а можно ли оставить только крайние числа, сделать так 1-6, вместо 1, 2, 3, 4, 5, 6?

  3. С помощью конкретно этой функции - нет. А вообще - можно все. Дописываете код или пишите свой, который будет выполнять конкретно Вашу задачу.

  4. Альт-Стар:

    КАК ВАС БЛАГОДАРИТЬ?

    АПЛОДИРУЕМ СТОЯ!!!!!!!!!!

  5. Надежда:

    Огромное спасибо за формулу!
    А может подскажите, как правильно написать код, чтобы было 2 диапазона условия?
    т.е. диапазон1; Критерий1; диапазон2; Критерий2;
    как в СуммЕслиМН. оеально это сделать? спасибо!

  6. Надежда, только правкой кода.

  7. Екатерина:

    Автор, реальный тебе РЕСПЕКТ!!!!!
    Бью поклоны за избавление от ручного сцепления 3,5 тысяч значений!
    СПАСИБО!!!!!!!

  8. Макс:

    Отличная функция, но работает если данные на одном листе. Не получилось ни с разных файлов сравнивать (тупо вылетает Excel по ошибке), ни с разных листов....

  9. Макс, а функция и не сравнивает. Она берет данные для просмотри и сцепления с одного листа. Критерии при этом могут быть откуда угодно. Что у Вас там вылетает не знаю.

    • Макс:

      Если ячеек более 37000 то функция не срабатывает, это факт. Причем если критерии находятся в другом файле, то Excel вываливается по ошибке. Вместо того что придираться к словам обратили бы внимание на свои ошибки. Удачи Вам.

  10. Макс, как скажете. Не буду придираться. Но сравнивать и сцеплять понятия разные - кто знает как Вы поняли функцию и для чего применить пытаетесь. Может Вы хотите навязать ей то, чего она не умеет. Поэтому я уточнил, но нисколько не придирался. Не надо по себе людей судить.
    И вот другой факт: у меня функция РАБОТАЕТ. И не только у меня, судя по комментариям. Без Вашего примера сказать почему не работает у Вас нереально. Может у Вас книги в разных процессах открыты. А может еще что.
    Плюс, если у Вас так много значений - есть вероятность, что результирующая строка содержит больше символов, чем допускается для записи в ячейку. И функция просто завершается с ошибкой, т.к. не может занести данные. Ничего с этим не сделать, т.к. это ограничения самого Excel.
    И еще момент: нехватка свободной памяти для обработки таких объемных данных. VBA просто не может поместить их в массивы.

    P.S. Про "обратили бы внимание на свои ошибки". А Вам не кажется, что я ничем Вам не обязан, чтобы что-то для Вас лично исправлять? Функция не работает только у Вас. Причины я описал выше. Хотите с ними разобраться - выкладывайте файл со своими данными на файлообменник, а ссылку на него сюда. Не забудьте прописать там функцию. Я скачаю, посмотрю. И тогда будет видно, где и чья ошибка.

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

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


Для оформления сообщений Вы можете использовать следующие тэги:
<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 для всех   Войти