Склеивание текста по условию

Вариант 1. Сцепить текст по одному условию

Про то, как можно быстро склеивать текст из нескольких ячеек в одну и, наоборот, разбирать длинную текстовую строку на составляющие я уже писал. Теперь же давайте рассмотрим близкую, но чуть более сложную задачу - как склеивать текст из нескольких ячеек при выполнении определенного заданного условия. Допустим, что у нас имеется база данных по клиентам, где одному названию компании может соответствовать несколько разных email'ов ее сотрудников. Наша задача состоит в том, чтобы собрать все адреса по названиям компаний и сцепить их (через запятую или точку с запятой), чтобы сделать потом, например, почтовую рассылку по клиентам, т.е. получить на выходе что-то похожее на:

склеивание (сцепка) текста по условию

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

Стандартными средствами Excel такое сделать сложно, но можно легко выкрутиться с помощью небольшой пользовательской функции на VBA. Откройте редактор Visual Basic нажатием на сочетание клавиш Alt+F11 или с помощью кнопки Visual Basic на вкладке Разработчик (Developer). В открывшемся окне вставьте новый пустой модуль через меню Insert - Module и скопируйте туда текст нашей функции:

Function MergeIf(TextRange As Range, SearchRange As Range, Condition As String)
    Dim Delimeter As String, i As Long
    Delimeter = ", " 'символы-разделители (можно заменить на пробел или ; и т.д.)
    
    'если диапазоны проверки и склеивания не равны друг другу - выходим с ошибкой
    If SearchRange.Count <> TextRange.Count Then
        MergeIf = CVErr(xlErrRef)
        Exit Function
    End If
    
    'проходим по все ячейкам, проверяем условие и собираем текст в переменную OutText
    For i = 1 To SearchRange.Cells.Count
        If SearchRange.Cells(i) Like Condition Then OutText = OutText & TextRange.Cells(i) & Delimeter
    Next i
    
    'выводим результаты без последнего разделителя
    MergeIf = Left(OutText, Len(OutText) - Len(Delimeter))
End Function

Если теперь вернуться в Microsoft Excel, то в списке функций (кнопка fx в строке формул или вкладка Формулы - Вставить функцию) можно будет найти нашу функцию MergeIf в категории Определенные пользователем (User Defined). Аргументы у функции следующие:

функция сцепить если выполняется условие

Вариант 2. Сцепить текст по неточному условию

Если заменить в 13-й строчке нашего макроса первый знак = на оператор приблизительного совпадения Like, то можно будет осуществлять склейку по неточному совпадению исходных данных с критерием отбора. Например, если название компании может быть записано в разных вариантах, то мы можем одной функцией проверить и собрать их все:

склейка по приблизительному условию

Поддерживаются стандартные спецсимволы подстановки:

  • звездочка (*) - обозначает любое количество любых символов (в т.ч. и их отсутствие)
  • вопросительный знак (?) - обозначает один любой символ
  • решетка (#) - обозначает одну любую цифру (0-9)

По умолчанию оператор Like регистрочувствительный, т.е. понимает, например, "Орион" и "оРиОн" как разные компании. Чтобы не учитывать регистр можно добавить в самое начало модуля в редакторе Visual Basic строчку Option Compare Text, которая переключит Like в режим, когда он невосприимчив к регистру.

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

  • ?1##??777RUS - выборка по всем автомобильным номерам 777 региона, начинающимся с 1
  • ООО* - все компании, название которых начинается на ООО
  • ##7## - все товары с пятизначным цифровым кодом, где третья цифра 7
  • ????? - все названия из пяти букв и т.д.

Вариант 3. Сцепить текст по нескольким условиям

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

Function MergeIfs(TextRange As Range, SearchRange1 As Range, Condition1 As String, SearchRange2 As Range, Condition2 As String)
    Dim Delimeter As String, i As Long
    Delimeter = ", " 'символы-разделители (можно заменить на пробел или ; и т.д.)
    
    'если диапазоны проверки и склеивания не равны друг другу - выходим с ошибкой
    If SearchRange1.Count <> TextRange.Count Or SearchRange2.Count <> TextRange.Count Then
        MergeIfs = CVErr(xlErrRef)
        Exit Function
    End If
    
    'проходим по все ячейкам, проверяем все условия и собираем текст в переменную OutText
    For i = 1 To SearchRange1.Cells.Count
        If SearchRange1.Cells(i) = Condition1 And SearchRange2.Cells(i) = Condition2 Then
            OutText = OutText & TextRange.Cells(i) & Delimeter
        End If
    Next i
    
    'выводим результаты без последнего разделителя
    MergeIfs = Left(OutText, Len(OutText) - Len(Delimeter))
End Function

Применяться она будет совершенно аналогично - только аргументов теперь нужно указывать больше:

склейка по нескольким условиям

Ссылки по теме


MCH
03.08.2014 09:42:19
В качестве предложения, Delimeter лучше передавать в функцию опционально, будет более универсально, по умолчанию задать запятую с пробелом, но и пользователь сам может задать любое альтернативное значение.

Не понятно, зачем MergeIf = CVErr(xlErrRef)?
Функция MergeIf определена как строковая, она не может вернуть значение ошибки #ССЫЛКА!, результатом данной строки будет ошибка #ЗНАЧ!, т.к. присваивается недопустимое значение строковой переменной и до строки Exit Function дело даже не доходит.
Если тип функции был Variant, тогда другое дело.

И еще, Николай, почему Вы не объявляете все переменные, в данном примере не объявлена переменная OutText, что не дает возможности использовать Option Explicit
Объявление не всех переменных наблюдается и в PLEX.
03.08.2014 10:35:46
Традиционно спасибо, МСН :) Про Variant и объявление переменных - согласен, поправил. Delimeter можно и опциональным аргументом передавать, конечно, дело вкуса.
22.08.2014 14:21:10
Спасибочки!!!:)
16.10.2014 16:46:54
Николай, огромное спасибо за макрос, действенно.
Единственный вопрос: а как заставить формулу сцепить только уникальные значения?
Например, у меня есть сводная таблица:
Фирма1Город1 Продавец1
Фирма1Город1 Продавец2
Фирма1Город1 Продавец3
Фирма1Город2 Продавец4
Фирма1Город2 Продавец3
Фирма1Город2 Продавец2
Фирма1Город3 Продавец1
Фирма1Город3 Продавец4
Фирма2 ...
Фирма3 ...
...

Я по маске хочу вытащить всех продавцов для Фирмы1 во всех городах (пишу *фирма1*) и оно мне выдает не 4 уникальных продавца, а все 8 записей, (предсказуемо) задваивая некоторых продавцов.
Мне кажется, как-то можно дописать условие проверки на повторы, но мои познания в VBA не столь глубоки :(

Заранее спасибо!
23.11.2014 09:38:36
А если сначала просто удалить дубликаты?
25.11.2014 17:11:52
Там была сложная таблица с кучей переменных, так не работает)
Решилось (немного коряво) формированием пайвота и перетягиванием его каждый раз так так, чтобы для каждой отдельной переменной были уникальные сочетания..
12.02.2016 18:57:18
Есть ряд столбцов, суммирующихся по определённому признаку. Для этих сумм надо написать описание в тексте, собственно Ваш макрос очень помог.
Но ряд значений действительно повторяются, существует ли какая-то альтернатива?
22.10.2014 15:32:07
Добрый день Николай!
сделал как все написано, но выдает ошибку #ЗНАЧ -связано ли это с тем что в первом столбце не текст а номера (числовые значения)? Вроде все столбцы перевел в "текстовый" формат -все равно не получается запустить.
Заранее спасибо!
23.11.2014 09:39:59
Сергей, попробуйте заменить в 13 строке первого макроса оператор Like на знак =
19.11.2014 15:18:19
А как сцепить только не пустые ячейки, но также по условию?
23.11.2014 09:36:10
Добавить в 13-ю строчку макроса проверку на пустоту в ячейке:
Function MergeIf(TextRange As Range, SearchRange As Range, Condition As String)
    Dim Delimeter As String, i As Long
    Delimeter = ", " 'символы-разделители (можно заменить на пробел или ; и т.д.)
     
    'если диапазоны проверки и склеивания не равны друг другу - выходим с ошибкой
    If SearchRange.Count <> TextRange.Count Then
        MergeIf = CVErr(xlErrRef)
        Exit Function
    End If
     
    'проходим по все ячейкам, проверяем условие и собираем текст в переменную OutText
    For i = 1 To SearchRange.Cells.Count
        If SearchRange.Cells(i) Like Condition And Len(TextRange.Cells(i))>0 Then OutText = OutText & TextRange.Cells(i) & Delimeter
    Next i
     
    'выводим результаты без последнего разделителя
    MergeIf = Left(OutText, Len(OutText) - Len(Delimeter))
End Function
24.11.2014 11:50:42
Спасибо большое! :)
16.02.2015 17:02:41
Добрый день! Николай, все сделал так как Вы написали, но почему то 2 формулы работают, остальные 2 пишут ЗНАЧ. Причем эти формулы находятся на одном листе и чередуются ( т.е. первая работает, вторая не работает). В чем может быть причина?
16.02.2015 18:50:55
Извиняюсь Николай)) нашел ошибку и устранил.
16.02.2015 19:12:57
Ничего страшного, бывает :)
17.02.2015 16:57:13
Привет всем! Николай, подскажите пожалуйста что делать? Вопрос такой: с помощью данного макроса я делаю некий отчет(за каждый месяц имеются определенные статьи газет, и по выбору месяца я хотел бы видеть все статьи за заданный период), т.е. условиями являются месяцы, и когда я меняю, условно говоря январь на февраль, у меня в формулах пишет #ИМЯ?
24.02.2015 11:40:54
Николай, спасибо за макрос )) Скажите, пожалуйста, как сделать, чтобы вместо запятой текст начинался все время с новой строки.
24.02.2015 19:50:17
Просто замените в третьей строке символ разделителя (запятую) на символ переноса строки (его код 10), т.е.
 Delimeter = Chr(10)
25.02.2015 10:52:00
Я уже так пробовала, в результате все в одной строке без пробелов. Сегодня еще раз попробовала в новом файле, скопировала код и поменяла 3 строку - тоже самое :oops: А потом когда я уже сдалась почти, оказалось что нужно просто нажать кнопку перенос текста :D
25.02.2015 10:55:25
В общем самой за себя стыдно :D
25.02.2015 11:28:24
:D Все ОК - бывает
26.02.2015 13:49:23
Здравствуйте! Помогите, пожалуйста с решением. Задача: в отдельной ячейке склеить весь текст, который высвечивается в последнем столбце.

Есть таблица:
№ офисаКол-во заявокИз них состоялосьПланНе заказали
152не выполнен
200не заказали№2
333выполнен
400не заказали№4
500
не заказали
№5
Я склеивала текст из нескольких ячеек в одну, но проблема в том, что пустая строка (как, например, между №№ 2 и 4) в склеенном тексте выдает лишние пробелы. Мне же нужно их исключить. Либо автоматически выбирать и склеивать только те ячейки, в которых содержится текст.

Как это сделать?
26.02.2015 23:02:27
Замените на этот блок, блок из оригинала.
'проходим по всем ячейкам, проверяем условие и собираем текст в переменную OutText
For i = 1 To SearchRange.Cells.Count
    If TextRange.Cells(i) <> "" Then
        If SearchRange.Cells(i) Like Condition Then OutText = OutText & TextRange.Cells(i) & Delimeter
    End If
Next i
26.02.2015 21:49:35
На форуме тоже есть тема Универсальная функция Сцепить. Чем примечательна, у неё больше настроек (много различных условий, сортировка, вывод уникальных), но смысл тот же. Может кому пригодится.
21.04.2015 09:34:37
Добрый день!

пожалуйста, помогите с решением такой задачи: склеить текст в ячейках до ячейки содержащей "MF". По сути, необходимо чтобы текст, стоящий в ячейках До ячейки с MF отображался как единое целое, а ячейка с MF стояла отдельно.

Спасибо!
25.05.2015 13:48:03
Николай, добрый день!

Спасибо за ваши примеры!
Рассматриваю ваш вариант №1. Работает отлично, но если необходимо проработать объемную базу, то для каждого значения необходимо в ручную указывать условие. Это не совсем удобно.
Если же использовать эту формулу для первого значения, а затем распространить на все значения, то получается такая картина как у меня на скрине. Тоесть формула прописывает возле каждого дубля количество электронных адресов минус один эл адрес..
Возможно ли в формуле использовать какое то решение VBA по поиску дублей? При этом если распространить данную формулу по всему массиву, то электронные адреса бы склеивались у одного из дублей, но у последующих значений, которые дублируются сцепка не производилась бы.
07.07.2015 14:08:14
Сергей, в формуле используйте динамические и статические ссылки.
Динамические не меняются, если "растянуть" формулу.
Т.е. в Вашем случае в ячейке D2 пишем =MergeIf($B$2:$B$9;$A$2:$A$9;C2).
Потом растянуть формулу на весь столбец и будет меняться только последнее значение C2, C3 и т.д
07.07.2015 14:10:09
А для того чтобы не было дублей, скопируйте название компании на новый лист, уберите дубли (Данные - убрать дубликаты) и будет Вам счастье
06.08.2015 18:56:38
мне это больше подошло (источник http://excelfin.ru/index.php/opinion/77-root)
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' efSumText() - объединение строк по условию
' rngFind - диапазон поиска
' sFind - условие с применением символов маски "?" и "*"
' rngValues - диапазон объединения
' sDelimiter - разделитель
'
' Использование:
' =efSumText(a1:a100) - сцепка строк с использование запятой в качестве разделителя
' =efSumText(a1:a100; "а*";) - сцепка строк, начинающихся на букву "а"
' =efSumText(b1:b100; "с*о"; a1:a100) - сцепка строк из первого столбца с проверкой на условие (начинается на "с", заканчивается на "о" второго столбца
' =efSumText(c1:c100; ">100"; a1:a100) - сцепка строк из первого столбца с проверкой третьего столбца на число (>100)
' =efSumText(c1:c100; ">100"; a1:a100, "+";) - то же, но с разделителем "+"
'
' © 2011, www.excelfin.ru
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function efSumText(rngFind As Range, _
Optional sFind As String = "", _
Optional rngValues As Range = Nothing, _
Optional sDelimiter As String = ", ";) As String
Dim sResult As String
Dim nIdx As Long
Dim bFlag As Boolean
 
For nIdx = 1 To rngFind.Cells.Count
If Not IsError(rngFind.Cells(nIdx).Value) Then
bFlag = False
If (sFind = "";) Then
bFlag = True
ElseIf IsNumeric(rngFind.Cells(nIdx).Value) Then
On Error Resume Next
bFlag = Application.Evaluate(CStr(Val(rngFind.Cells(nIdx).Value)) & sFind)
On Error GoTo 0
Else
bFlag = (rngFind.Cells(nIdx).Value Like sFind)
End If
 
If bFlag Then
If (sResult <> "";) Then
sResult = sResult & sDelimiter
End If
 
If (rngValues Is Nothing) Then
sResult = sResult & CStr(rngFind.Cells(nIdx).Value)
Else
sResult = sResult & CStr(rngValues.Cells(nIdx).Value)
End If
End If
End If
Next
efSumText = sResult
End Function
07.08.2015 10:01:01
А также от одного из великих (душой и мастерством VBA) людей на этом (и на своём) сайте. The_Prist.
Версия лучше тем, что есть возможность сцеплять значения без их повторения (уникальные). Браво! 8)
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : СцепитьЕсли
' DateTime  : 10.09.2010 13:42
' Author    : The_Prist(Дмитрий); WebMoney - R298726502453; Яндекс.Деньги - 41001332272872;
'             http://www.excel-vba.ru
' Purpose   : http://www.excel-vba.ru/index.php?file=Tips_Macro_CoupleIF
'---------------------------------------------------------------------------------------
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)
        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
12.08.2015 12:37:13
Добрый день.
подскажите пожалуйста, как следует изменить макрос, чтобы он вписывал в ячейку данные таким образом:

1 2 3 4 5
1 а б в д а,e;б,ё;в,ж
2 е ё ж з;и;й
3 з и й к л;м;н
4 л м н о
т.е грубо говоря, поочерёдно вписывала все значения ячеек данного столбца через запятую, после данные из следующих столбцов (между столбцами разделитель точка с запятой) до тех пор пока не будет выведено не пустое значение в контрольном столбце, а после проделала бы то же самое на следующей строчке. гарантируется, что первое и последнее значение контрольного столбца не пустые, но значения столбцов из которых нужно брать данные могут оказаться пустыми, в этом случае не нужно выводить несколько разделителей. да, и ещё, желательно, чтобы перед значениями указывалось бы название столбца (т.е в моей таблице -это значение первой ячейки), тогда первая строка исходных значений в приведённой мной таблице для примера будет иметь вид: название ячейки 1:а,е;название ячейки 2:б,ё;название ячейки 3:в,ж (между названиями столбцов и данными ячеек пусть будет разделитель двоеточие, а в случае пустых значений (во всех ячейках) -не указывалось бы название вообще). Заранее спасибо за ответ.
13.08.2015 16:45:33
Павел, добрый день.
Ваше решение особенно по не точным условиям считаю лучшим ,как по простоте реализации так и по функциональности. Большое спасибо.
Пытаюсь адаптировать под мою задачу.

Подскажите, пожалуйста,

как в качестве разделителя использовать:
вначале нумерацию, затем значение подобранное по условию, затем точку с запятой,
при этом что бы начать с нвой строки я так понял втавить (Delimeter = Chr(10)).

С уважением, Алексей.
09.09.2015 17:18:55
Здравствуйте,примеров много видела,но так как опыта нет,обращаюсь к Вам, с просьбой.
у меня есть 2 поля(INTEGER)

INN PhoneNumber
344565667678 80976338834

Мне нужно склеить так:
(344565667678, 80976338834)

желательно макрос, можно и функцию.
Заранее благодарна
27.10.2016 13:56:05
Добрый день. у меня имеется реестр названий нарушений с датами, (2 столбца. нарушение - дата)
Требуется сцепить даты с одного периода до другого периода включительно. как это реализовать?
По данной формуле оно вытягивает вообще все даты которые есть в реестре.
31.10.2016 19:24:14
я б предложил простой спсоб:добавить столкиб с условием (функция если) которая бы реагировала на условие в заданных ячейках. если истина то к примеру в столбике появляется "да", или пусто. далее с помощью функции выше указал бы условие сцепить ячейки с текстом "да"
01.11.2016 09:01:22
Я короче применил эту формулу к сводной таблице в который только выбранный период и получил то что хотел.
31.10.2016 19:25:24
у меня почему то через какое-то время выдает ошибку "знач" и функция больше не работает(
с чем может быть связано?