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

 

Решение стандартными формулами
Стандартными функциями это сделать весьма проблематично, т.к. заранее неизвестно сколько будет этих оценок и фамилий.. Microsoft работает над усовершенствованием Excel и теперь стало возможным сделать это и стандартными функциями. Правда, с небольшими ограничениями: сделать это могут только пользователи Excel 2019 и выше или Office 365 по подписке. В итоге счастливые обладатели новейших версий могут использовать достаточно несложные формулы:
=ОБЪЕДИНИТЬ("; ";1;ФИЛЬТР(B2:B20;A2:A20=A2;""))
=TEXTJOIN("; ",1,FILTER(B2:B20,A2:A20=A2,""))
Аргументы функции:

  • ("; ") - символ(или несколько символов), которым необходимо объединять найденные значения
  • (A2:A20) - диапазон, в котором искать критерий
  • (A2) - критерий. Значение, на основании которого необходимо сцеплять значения. Значение просматривается в диапазоне значений(A2:A20)
  • (B2:B20) - из этого диапазона берется значение для сцепления, если значение напротив в диапазонe(A2:A20) совпадает с искомым значением A2

Для любителей "старой школы" можно вместо функции ФИЛЬТР(FILTER) использовать стандартную ЕСЛИ(IF):
=ОБЪЕДИНИТЬ("; ";1;ЕСЛИ(A2:A20=A2;B2:B20;""))
=TEXTJOIN("; ",1,IF(A2:A20=A2,B2:B20,""))
так же это можно использовать в Excel 2019 в случае, если функция ФИЛЬТР отсутствует - да, может быть и такое, хоть Microsoft и пишет, что она там поддерживается
Аргументы точно такие же, как в формуле выше. Правда эта формула вводится в ячейку как формула массива(т.е. одновременным нажатием трех клавиш Ctrl+Shift+Enter).
Хотя в самых новых версия(а-ля 365) вводить тремя клавишами уже не обязательно - Excel сам поймет, что требуется обработка массива ячеек.

 

Объединяем текст по критерию при помощи написания собственной UDF - СцепитьЕсли
А для пользователей Excel 2016 и ниже я написал небольшую функцию пользователя на 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

Чтобы правильно использовать приведенный код, необходимо сначала ознакомиться со статьей Что такое функция пользователя(UDF)?. Вкратце: скопировать текст кода выше, перейти в редактор VBA(Alt+F11) -создать стандартный модуль(Insert -Module) и в него вставить скопированный текст. После чего функцию СцепитьЕсли можно будет вызвать из Диспетчера функций(Shift+F3), отыскав её в категории Определенные пользователем (User Defined Functions).
Синтаксис записи в ячейку листа:
=СцепитьЕсли(A2:A20;A2;B2:B20;"; ";0)

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

Диапазон(A2:A20) - диапазон, в котором искать критерий(указывается один столбец). В данном случае это столбец с названиями отделов.

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

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

Разделитель("; ") - По умолчанию пробел, но можно задать любой другой символ или группу символов. Если необходимо в качестве разделителя использовать символ переноса на новую строку, то его следует записать как функцию: СИМВОЛ(10) (CHAR(10)). Для отображения переноса в ячейке с функцией необходимо для ячейки включить отображение переносов строк(вкладка Главная -группа Выравнивание -Переносить текст).

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

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

  Пример СцепитьЕсли.xls (68,0 КиБ, 16 938 скачиваний)

 

Объединяем текст по нескольким критериям при помощи UDF - СцепитьЕсли2
По многочисленным просьбам написал UDF, которая может объединять значения по нескольким условиям. Допускается до 4-х условий, но при наличии желания и небольших навыков можно расширить это число хоть до 100.
Основная функция - СцепитьЕсли2. Но она использует еще и вспомогательные функции для более удобного добавления новых критериев: GetArr, GetIntersectRange и Get_Match. Пояснения к каждой функции написаны в заголовках функций, так что понять, что делает какая из них не должно быть проблемой для тех, у кого появится желание доработать код.

'---------------------------------------------------------------------------------------
' Author : Щербаков Дмитрий(The_Prist)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
' Purpose:
'---------------------------------------------------------------------------------------
Option Explicit
Option Compare Text
Dim objRegExp As Object
'---------------------------------------------------------------------------------------
' Purpose: Функция СцепитьЕсли2 объединяет строки по заданным условиям. Допускается указание до 4-х условий
'   Критерий                    - условие отбора. Ссылка на ячейку или значение. Может начинаться на операторы сравнения: =; <>; =>; >=; <=; =<; >; <
'   Диапазон                    - диапазон, в котором просматривать условия(критерии)
'   Диапазон_сцепления          - диапазон из одной строки или столбца, из которого брать значения для объединения в одну строку
'   Разделитель                 - Символ или символы, который используется для объединения отобранных значений
'   БезПовторов                 - 1 или ИСТИНА(True) - в итоговую строку будут собраны только уникальные значения
'   Диапазон2,Критерий2 и т.д.  - дополнительные связки Диапазон-Критерий. До 4-х
'---------------------------------------------------------------------------------------
Function СцепитьЕсли2(ByRef Диапазон As Range, ByVal Критерий, ByRef Диапазон_сцепления As Range, _
                     Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False, _
                     Optional ByRef Диапазон2 As Range, Optional ByVal Критерий2, _
                     Optional ByRef Диапазон3 As Range, Optional ByVal Критерий3, _
                     Optional ByRef Диапазон4 As Range, Optional ByVal Критерий4) As String
 
    Dim oDict As Object
    Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long
    Dim avDateArr2(), avDateArr3(), avDateArr4()
    Dim rr As Range
    Dim bCompare As Boolean, IsR2 As Boolean, IsR3 As Boolean, IsR4 As Boolean
    Dim skey$, stxt$
    Dim sTmpStr
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.comparemode = 1
 
    'определяем, все ли связки Диапазон-Критерий указаны
    'далее проверяем только условия, для которых есть Диапазон и Критерий
    IsR2 = Not IsMissing(Критерий2) And Not Диапазон2 Is Nothing
    IsR3 = Not IsMissing(Критерий3) And Not Диапазон3 Is Nothing
    IsR4 = Not IsMissing(Критерий4) And Not Диапазон4 Is Nothing
    'определяем вхождение диапазонов в рабочий диапазон
    'нужно, чтобы отсечь лишние строки/столбцы при указании полных строк и столбцов
    'Диапазон 1
    Set rr = GetIntersectRange(Диапазон)
    If rr Is Nothing Then
        Exit Function
    End If
    avDateArr = GetArr(rr)
    'Диапазон Сцепления
    Set rr = GetIntersectRange(Диапазон_сцепления)
    If rr Is Nothing Then
        Exit Function
    End If
    avRezArr = GetArr(rr)
    'Диапазон 2
    If IsR2 Then
        Set rr = GetIntersectRange(Диапазон2)
        If rr Is Nothing Then
            IsR2 = False
        Else
            avDateArr2 = GetArr(rr)
        End If
    End If
    'Диапазон 3
    If IsR3 Then
        Set rr = GetIntersectRange(Диапазон3)
        If rr Is Nothing Then
            IsR3 = False
        Else
            avDateArr3 = GetArr(rr)
        End If
    End If
    'Диапазон 4
    If IsR4 Then
        Set rr = GetIntersectRange(Диапазон4)
        If rr Is Nothing Then
            IsR4 = False
        Else
            avDateArr4 = GetArr(rr)
        End If
    End If
    'если диапазоны указаны горизонтально - разворачиваем в вертикальный массив
    If Диапазон.Columns.Count > 1 And Диапазон.Rows.Count = 1 Then
        avDateArr = Application.Transpose(avDateArr)
        If IsR2 Then
            avDateArr2 = Application.Transpose(avDateArr2)
        End If
        If IsR3 Then
            avDateArr3 = Application.Transpose(avDateArr3)
        End If
        If IsR4 Then
            avDateArr4 = Application.Transpose(avDateArr4)
        End If
        avRezArr = Application.Transpose(avRezArr)
    End If
 
    lUBnd = UBound(avDateArr, 1)
    'Опрееделяем вхождение операторов сравнения в Критерий
    If objRegExp Is Nothing Then
        Set objRegExp = CreateObject("VBScript.RegExp")
        objRegExp.Global = False
        objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<"
    End If
 
    For li = 1 To lUBnd
        bCompare = True
        If Not Get_Match(Критерий, avDateArr(li, 1)) Then
            bCompare = False
        End If
        '2 диапазон и критерий
        If IsR2 And bCompare Then
            If Not Get_Match(Критерий2, avDateArr2(li, 1)) Then
                bCompare = False
            End If
        End If
        '3 диапазон и критерий
        If IsR3 And bCompare Then
            If Not Get_Match(Критерий3, avDateArr3(li, 1)) Then
                bCompare = False
            End If
        End If
        '4 диапазон и критерий
        If IsR4 And bCompare Then
            If Not Get_Match(Критерий4, avDateArr4(li, 1)) Then
                bCompare = False
            End If
        End If
        If bCompare Then
            stxt = Trim(avRezArr(li, 1))
            If Len(stxt) Then
                If БезПовторов Then
                    skey = stxt
                Else
                    skey = oDict.Count + 1
                End If
                oDict.Item(skey) = stxt
            End If
        End If
    Next li
 
    sTmpStr = oDict.items
    For li = LBound(sTmpStr) To UBound(sTmpStr)
        If Len(sStr) = 0 Then
            sStr = sTmpStr(li)
        Else
            sStr = sStr & Разделитель & sTmpStr(li)
        End If
    Next
 
    СцепитьЕсли2 = sStr
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetArr
'             rr    - ссылка на диапазон, из значений которого надо создать массив
'---------------------------------------------------------------------------------------
Function GetArr(rr As Range)
    Dim arr
    arr = rr.Value
    If Not IsArray(arr) Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    End If
    GetArr = arr
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetArr
'             получаем только тот диапазон, который используется на листе
'             Диапазон    - ссылка на диапазон
'---------------------------------------------------------------------------------------
Function GetIntersectRange(Диапазон As Range)
    Set GetIntersectRange = Intersect(Диапазон, Диапазон.Parent.UsedRange)
End Function
'---------------------------------------------------------------------------------------
' Procedure : Get_Match
'             получаем только тот диапазон, который используется на листе
'             vCr       - условие, на которое проверяем значение диапазона(vCompare)
'             vCompare  - значение, которое проверяем на соответствие заданному критерию(vCr)
'---------------------------------------------------------------------------------------
Function Get_Match(ByVal vCr, ByVal vCompare) As Boolean
    Dim sStr As String, sStrMatch As String
    Dim objMatches As Object
 
    Set objMatches = objRegExp.Execute(vCr)     'Если есть вхождения
    If objMatches.Count > 0 Then
        sStrMatch = objMatches.Item(0)
        vCr = Replace(Replace(vCr, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
    End If
 
    If IsNumeric(vCr) And vCr <> "" Then
        vCr = CDbl(vCr)
    End If
    Select Case sStrMatch
    Case "="
         If vCompare = vCr Then Get_Match = True
    Case "<>"
        If vCompare <> vCr Then Get_Match = True
    Case ">=", "=>"
        If vCompare >= vCr Then Get_Match = True
    Case "<=", "=<"
        If vCompare <= vCr Then Get_Match = True
    Case ">"
        If vCompare > vCr Then Get_Match = True
    Case "<"
        If vCompare < vCr Then Get_Match = True
    Case Else
        If vCompare Like vCr Then Get_Match = True
    End Select
End Function

Аргументы функции точно такие же, как и в описанной выше СцепитьЕсли, но с возможностью последними аргументами добавить еще критерия и диапазоны, где их просматривать. Требования к ним точно такие же, как и к аргументам Диапазон и Критерий.
На примере таблицы сотрудников отберем не повторяющихся сотрудников планового отдела, год рождения которых позже 1978:
Пример работы функции СцепитьЕсли2
Синтаксис записи в ячейку листа:
=СцепитьЕсли2(A2:A20;A2;B2:B20;"; ";1;C2:C20;">1970")

Как видно, все основные аргументы записаны в том же порядке, за исключением последних двух:
Диапазон2(С2:С20) - диапазон для просмотра второго условия отбора. В данном случае это столбец с годом рождения.
Критерий2(">1978") - т.к. нам необходимо отобрать только тех сотрудников, год рождения которых позже 1978, то для этого аргумента указываем значение ">1978".

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

Loading

96 комментариев

  1. Добрый день, всё работает. Спасибо.
    Не получается в разделителе указать СИМВОЛ(10). Надо чтоб текст был на разных строках. Как это можно сделать?

    1. Роман, не совсем понятно - не получается указать разделитель или даже после указания переноса на строки нет? Если второе - в ячейке с формулой установите перенос текста для ячеек(по умолчанию он отключен): Главная -Переносить текст.
      Саму функцию тогда следует записывать вроде того:
      =СцепитьЕсли(B5:B18;B5;C5:C18;СИМВОЛ(10);0)

  2. Дмитрий, функция просто космос!!)
    Но есть одна проблемка))
    Есть книга с 100 000+ срок, и формула протягивается оооооочень долго))
    Есть ли какая то альтернатива или можно ли как то ускорить функцию?)))
    Подскажите пожалуйста)))

    1. Volonar, альтернатива может быть только в офисе 2021 или 365(там можно нечто подобное сделать при помощи функций ОБЪЕДИНИТЬ и ФИЛЬТР). Ускорить же эту возможно лишь написав собственный код(не в виде функции, а отдельная процедура, которая будет обрабатывать все ячейки сразу), либо написав функцию вообще на другом языке и упаковав в XLL.

  4. Подскажите, почему после редактирования ячейки (даже после возврата прежних значений) функция перестаёт работать?
    Заранее спасибо.

    1. Алексей, нечего сказать, не зная, что значит "перестает работать". Просто не считает, ошибку выдает, еще что-то...Первое, что приходит в голову - Вы получаете ошибку #ИМЯ!, потому что макросы не были разрешены.

Добавить комментарий для Роман Отменить ответ

Этот сайт использует Akismet для борьбы со спамом. Узнайте, как обрабатываются ваши данные комментариев.