Забыли пароль?


Хитрости »
Основные понятия (24)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (17)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (65)
Разное (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, 11 547 скачиваний)

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


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

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

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

    Макрос работает не корректно, в частности не распознает четырёхзначные значения (например поле «Все сотрудники, с окладом меньше или равным 15000» не указывает значение «Петрова Вера», пока вместо её оклада «6000» не вбить значение «06000»

  2. zaolog:

    Подскажите пожалуйста, почему у меня не работает?
    http://screenshot.ru/b12ea1e7e077eeea29a9af222c82879c.png

    • Попробуйте при объявлении

      ByVal Критерий

      записать без типа:

      ByVal Критерий
      • zaolog:

        Добрый день, Дмитрий.
        Не вдупляю как это сделать, подскажите пожалуйста.

      • zaolog:

        Вроде бы поправил нужное ))
        Но теперь формула =СцепитьЕсли(D2:D16;">9";B2:B16;",") и вовсе не работает. Выдает ошибку #ЗНАЧ!

      • zaolog:

        Простите затупил, не то правил. Все заработало. Ура!!! Спасибо огромное за формулу.

  3. Татьяна:

    Функция работает на отлично. Огромное СПАСИБО разработчику.
    Пользовалась другими макросами, но после их запуска можно было идти спать.

  4. Добрый день.

    Скажите, пожалуйста, вот на версии х86 (32) работает нормально.
    А на версии офис х64, выдает ошибку #знач / # value.
    Может что-то нужно изменить в коде?

    • Камиль, сложно сказать. Сам код не зависит от битности системы. Ошибка у Вас появляется прямо в скачанном файле, без внесения в него правок? Макросы разрешены? Если нет - надо включить как положено, потому что очень похоже именно на это.

  5. Andrey B3:

    Дмитрий, здравствуйте

    подскажите как удалить этот макрос в случае необходимости?
    Установка и работа проблем не вызвали, всё работает как надо. Большое спасибо!

    • В общем-то ничего сложного: заходите в редактор VBA(Alt+F11) -переходите в модуль, в котором записан код функции и удаляете весь код от Function СцепитьЕсли до End Function.
      Только перед этим не забудьте преобразовать в значения результат вычисления этой функций: Как удалить в ячейке формулу, оставив значения?
      иначе все расчеты, сделанные этой функцией, будут утеряны.

      • Andrey B3:

        Я неточно выразился, мне нужно удалить сам модуль, а он под паролем

        • Андрей, вопрос не совсем по адресу тогда. В приложенном к статье файле нет пароля ни на листы, ни на проект VBA. Так что ничем помочь не могу, Вы, скорее всего используете файл не из статьи.

          • Andrey B3:

            Дмитрий, разобрался. Это надстройка которую я сам включил, Solver. Не знал что она решена как макрос и отобразится в окне с модулями) Извините за беспокойство, еще раз спасибо за качественный продукт.

  6. Алексей:

    Спасибо за данную функцию. Единственно, она не понимает именованные диапазоны, полученные в Диспетчере имен виде ФОРМУЛ. Если вывести такие именованные диапазоны в ячейки и сослаться на эти ячейки, то все работает, а вот если в формуле прямо сослаться на данные именованные диапазоны, то выдает #ЗНАЧ. Буду рад, если подскажете, как в коде прописать определение переменных, чтобы такие диапазоны все-таки понимались. Спасибо!

  7. Vic:

    Доброго! А подскажите, если мне нужно сцепить все данные по диапазону, за исключением данных в строке диапазона с КРИТЕРИЕМ?

    к примеру: =СцепитьЕсли(B5:B18;B10;C5:C18;"-";0)

    т.е. в сцепляемом диапазоне данных C5:C18, данные по В10 мы не сцепляем, а сцепка идет C5:C9 + C11:C18

    Помогите пожалуйста

    • Vic, здесь надо в коде обрабатывать этот момент. Притом придется либо еще один параметр вводить(вроде номеров строк для исключения из просмотра), либо переписывать принцип обработки.

      • Vic:

        Дмитрий, а если предположим, в следующей ячейке, с помощью какой-то формулы, вычтем из сцепленных данных, значение ячейки С10,

        т.е. D10 =СцепитьЕсли(B5:B18;B10;C5:C18;"-";0)
        D11 =.....D10-C10

        есть что-то подобное в excel ?

        • Vic:

          вопрос снят

          использовал в соседней ячейки минус "слово" =ПОДСТАВИТЬ(BE253;AZ253;) как раз из диапазона убирает ненужное значение

  8. Даниил:

    unction СЦЕПИТЬЕСЛИ(ByRef Диапазон As Range, ByVal Критерий As String, ByVal Критерий2 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 = "=||=>|>=|<=|=| 0 Then
    Dim sStrMatch As String
    sStrMatch = objMatches.Item(0)
    Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
    Критерий2 = Replace(Replace(Критерий2, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
    If IsNumeric(Критерий) And Критерий "" Then
    Критерий = CDbl(Критерий)
    If IsNumeric(Критерий2) And Критерий2 "" Then
    Критерий2 = CDbl(Критерий2)
    End If
    Select Case sStrMatch
    Case "="
    For li = 1 To lUBnd
    If avDateArr(li, 1) = Критерий And avDateArr(li, 1) = Критерий2 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) Критерий And avDateArr(li, 1) Критерий2 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) >= Критерий And avDateArr(li, 1) >= Критерий2 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) <= Критерий And avDateArr(li, 1) <= Критерий2 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) > Критерий And avDateArr(li, 1) > Критерий2 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) < Критерий And avDateArr(li, 1) < Критерий2 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 Критерий And avDateArr(li, 1) Like Критерий2 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
    Написал формулу для сцепления с 2мя условиями( по вашей рекомендации) не могли бы подпраить, что я сделал не так

    • Да много что не так. Вам помимо добавления второго критерия нужен и доп.диапазон, в котором критерий просматривать. А сейчас у Вас получается, что условия могут быть невыполнимы. Например, строка:

      If avDateArr(li, 1) = Критерий And avDateArr(li, 1) = Критерий2 Then

      здесь одно и то же значение сравнивается с двумя критериями. Т.е. если Критерий=Банан, а Критерий2 = Апельсин - условие никогда не выполнится, т.к. одно и тоже значение не может быть одновременно и Бананом и Апельсином.

      • Даниил:

        Уважаемый Дмитрий большое спасибо за ответ, не могли бы вы по много численным просьбам (заметил в коментариях, что не я один в этом заинтересован) составить функцию с 2мя критериями, чтобы по аналогии можно было писать коды с большим количесвом критериев. Спасибо Вам за проделаный труд.

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

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


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