Макрос сцепить если в excel

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

Про то, как можно быстро склеивать текст из нескольких ячеек в одну и, наоборот, разбирать длинную текстовую строку на составляющие я уже писал. Теперь же давайте рассмотрим близкую, но чуть более сложную задачу — как склеивать текст из нескольких ячеек при выполнении определенного заданного условия. 

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

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

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

Способ 0. Формулой

Не очень изящный, зато самый простой способ. Можно написать несложную формулу, которая будет проверять отличается ли компания в очередной строке от предыдущей.  Если не отличается, то приклеиваем через запятую очередной адрес. Если отличается, то «сбрасываем» накопленное, начиная заново:

Сцепка текста по условию формулой

Минусы такого подхода очевидны: из всех ячеек полученного дополнительного столбца нам нужны только последние по каждой компании (желтые). Если список большой, то чтобы их быстро отобрать придется добавить еще один столбец, использующий функцию ДЛСТР (LEN), проверяющий длину накопленных строк:

Отбор строк

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

Способ 1. Макрофункция склейки по одному условию

Если исходный список не отсортирован по компаниям, то приведенная выше простая формула не работает, но можно легко выкрутиться с помощью небольшой пользовательской функции на 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

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

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

Способ 4. Группировка и склейка в Power Query

Решить проблему можно и без программирования на VBA, если использовать бесплатную надстройку Power Query. Для Excel 2010-2013 ее можно скачать здесь, а в Excel 2016 она уже встроена по умолчанию. Последовательность действий будет следующей:

Power Query не умеет работать с обычными таблицами, поэтому первым шагом превратим нашу таблицу в «умную». Для этого ее нужно выделить и нажать сочетание Ctrl+T или выбрать на вкладке Главная — Форматировать как таблицу (Home — Format as Table). На появившейся затем вкладке Конструктор (Design) можно задать имя таблицы (я оставил стандартное Таблица1):

Умная таблица

Теперь загрузим нашу таблицу в надстройку Power Query. Для этого на вкладке Данные (если у вас Excel 2016) или на вкладке Power Query (если у вас Excel 2010-2013) жмем Из таблицы (Data — From Table):

Загрузка в Power Query

В открывшемся окне редактора запросов выделяем щелчком по заголовку столбец Компания и сверху жмем кнопку Группировать (Group By). Вводим имя нового столбца и тип операции в группировке — Все строки (All Rows):

Группировка в Power Query

Жмем ОК и получаем для каждой компании мини-таблицу сгруппированных значений. Содержимое таблиц хорошо видно, если щелкать левой кнопкой мыши в белый фон ячеек (не в текст!) в получившемся столбце:

Содержимое таблиц группировки

Теперь добавим еще один столбец, где с помощью функции склеим через запятую содержимое столбцов Адрес в каждой из мини-таблиц. Для этого на вкладке Добавить столбец жмем Пользовательский столбец (Add column — Custom column) и в появившемся окне вводим имя нового столбца и формулу сцепки на встроенном в Power Query языке М:

Пользовательский столбец с функцией склейки

Обратите внимание, что все М-функции регистрочувствительные (в отличие от Excel). После нажатия на ОК получаем новый столбец со склееными адресами:

Результат

Осталось удалить ненужный уже столбец ТаблАдресов (правой кнопкой мыши по заголовку — Удалить столбец) и выгрузить результаты на лист, нажав на вкладке Главная — Закрыть и загрузить (Home — Close and load):

Выгрузка результатов на лист

Важный нюанс: в отличие от предыдущих способов (функций), таблицы из Power Query не обновляются автоматически. Если в будущем произойдут какие-либо изменения в исходных данных, то нужно будет щелкнуть правой кнопкой в любое место таблицы результатов и выбрать команду Обновить (Refresh).

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

  • Как разделить длинную текстовую строку на части
  • Несколько способов склеить текст из разных ячеек в одной
  • Использование оператора Like для проверки текста по маске

Хитрости »

1 Май 2011              164077 просмотров


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

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


А для пользователей 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) -создать стандартный модуль(InsertModule) и в него вставить скопированный текст. После чего функцию СцепитьЕсли можно будет вызвать из Диспетчера функций(Shift+F3), отыскав её в категории Определенные пользователем (User Defined Functions).
Синтаксис записи в ячейку листа:
=СцепитьЕсли(A2:A20;A2;B2:B20;»-«;0)

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

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

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

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

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

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

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

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

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


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


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

  Плейлист   Видеоуроки


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



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

Функция (UDF) «СцепитьЕсли»

Alex_ST

Дата: Четверг, 26.08.2010, 11:29 |
Сообщение № 1

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3176


Репутация:

604

±

Замечаний:
0% ±


2003

=======================================================
Функция (UDF) «СцепитьЕсли»
=======================================================
Данная Определенная пользователем функция (User-Defined Function или UDF) возвращает в ячейку листа, куда она введена, «склеенные» в одну строку тексты из ячеек заданного диапазона при выполнении заданного условия с задаваемыми при необходимости разделителями данных из разных ячеек.
[vba]

Код

Function СцепитьЕсли(ByRef Диапазон As Range, _
                    ByVal Критерий As String, _
                    ByRef Диапазон_сцепления As Range, _
                    Optional Разделитель As String = » «) As String
            ‘—————————————————————————————
            ‘ Procedure    : СцепитьЕсли
            ‘ Author       : The_Prist & Alex_ST
            ‘ Topic_HEADER : «Помогите создать СЦЕПИТЬЕСЛИ() — аналог СУММЕСЛИ()»
            ‘ Topic_URL    : http://www.planetaexcel.ru/forum.php?thread_id=14935
            ‘ Post_Author  : The_Prist
            ‘ Post_URL     : http://www.planetaexcel.ru/docs/forum_upload/post_113923.xls
            ‘ DateTime     : 02.04.2010 22:24
            ‘ Purpose      : СЦЕПИТЬЕСЛИ() — аналог СУММЕСЛИ()
            ‘ Notes        : По умолчанию разделитель слов — пробел, но можно задать любой другой символ/символы.
            ‘              Диапазон — диапазон с критериями(указывается один столбец)
            ‘              Критерий — критерий. Просматривается Диапазон.
            ‘              Диапазон_сцепления — из этого диапазона берется значение для сцепления,
            ‘              если значение в аргументе Диапазон совпадает с аргументом Критерий (указывается один столбец).
            ‘—————————————————————————————
            Dim rCell As Range, rFndrng As Range, sStr As String
            Set Диапазон = Intersect(Диапазон, ActiveSheet.UsedRange)
            Set Диапазон_сцепления = Intersect(Диапазон_сцепления, ActiveSheet.UsedRange)
            For Each rCell In Диапазон
               If rCell.Value Like Критерий Then
                  If Trim(Диапазон_сцепления.Cells(rCell.Row — Диапазон.Row + 1, 1)) <> «» Then _
                     sStr = sStr & IIf(sStr <> «», Разделитель, «») & Диапазон_сцепления.Cells(rCell.Row — Диапазон.Row + 1, 1)
               End If
            Next rCell
            СцепитьЕсли = sStr
End Function

[/vba]



С уважением,
Алексей
MS Excel 2003 — the best!!!

Сообщение отредактировал Alex_STЧетверг, 26.08.2010, 13:52

 

Ответить

Serge_007

Дата: Пятница, 10.09.2010, 14:34 |
Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 15894


Репутация:

2623

±

Замечаний:
±


Excel 2016

Аналогичная функция:

[vba]

Код

‘—————————————————————————————
‘ Procedure : СцепитьЕсли
‘ Author    : The_Prist(Дмитрий); http://www.excel-vba.ru
‘ Purpose   : Функция сцепляет данные из диапазона, указанного критерием Диапазон_сцепления
‘             в том случае, если ячейка из критерия Диапазон входит в условие
‘             указанное Критерием. В качекстве Критерия может быть ссылка на ячейку,
‘             либо текст/число, либо операторы сравнения
‘             (как все привыкли в СУММЕСЛИ, СЧЁТЕСЛИ и т.д. — «<>»»»,»>8″ и пр.).
‘—————————————————————————————
Function СцепитьЕсли(ByRef Диапазон As Range, ByVal Критерий As String, ByRef Диапазон_сцепления As Range, Optional Разделитель As String = » «) As String
       Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long
       If Диапазон.Count > 1 Then
           avDateArr = Intersect(Диапазон, Application.Caller.Parent.UsedRange).Value
           avRezArr = Intersect(Диапазон_сцепления, Application.Caller.Parent.UsedRange).Value
           If Диапазон.Rows.Count = 1 Then
               avDateArr = Application.Transpose(avDateArr)
               avRezArr = Application.Transpose(avRezArr)
           End If
       Else
           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
       СцепитьЕсли = sStr
End Function

[/vba]

Источник


ЮMoney:41001419691823 | WMR:126292472390

 

Ответить

The_Prist

Дата: Вторник, 10.05.2011, 08:09 |
Сообщение № 3

Группа: Друзья

Ранг: Участник

Сообщений: 84


Репутация:

22

±

Замечаний:
0% ±


2010

Сергей, привет.
А разьве ссылку на источник не надо указыать? :-) Я вроде делал пометку на сайте. Нехорошо получается…


Errare humanum est, stultum est in errore perseverare

 

Ответить

Serge_007

Дата: Вторник, 10.05.2011, 10:30 |
Сообщение № 4

Группа: Админы

Ранг: Местный житель

Сообщений: 15894


Репутация:

2623

±

Замечаний:
±


Excel 2016

Quote (The_Prist)

Сергей, привет.
А разьве ссылку на источник не надо указыать? :-) Я вроде делал пометку на сайте. Нехорошо получается…

Привет Дим.
Посмотри вторую строку:
Мало того что ссылка на источник, так ещё и автор указан smile


ЮMoney:41001419691823 | WMR:126292472390

 

Ответить

The_Prist

Дата: Вторник, 10.05.2011, 10:58 |
Сообщение № 5

Группа: Друзья

Ранг: Участник

Сообщений: 84


Репутация:

22

±

Замечаний:
0% ±


2010

Quote (Serge_007)

Мало того что ссылка на источник, так ещё и автор указан

Сергей, то, что в коде указан автор и его сайт не является ссылкой на источник. Ссылка на источник выглядит как ссылка на статью(саму ссылку можешь потом удалить из моего поста — это для демонстрации того, как ссылка выглядит). Я её не вижу :-)
Мое мнение: раз уж листинг кода полностью берётся с какой-либо страницы сайта, то и ссылка должна быть на страницу первоисточника.
Конечно, мое мнение может не совпадать с твоим и спорить не собираюсь. Это лишь высказывание мнения.


Errare humanum est, stultum est in errore perseverare

Сообщение отредактировал The_PristВторник, 10.05.2011, 11:00

 

Ответить

Serge_007

Дата: Вторник, 10.05.2011, 11:41 |
Сообщение № 6

Группа: Админы

Ранг: Местный житель

Сообщений: 15894


Репутация:

2623

±

Замечаний:
±


Excel 2016

Quote (The_Prist)

…раз уж листинг кода полностью берётся с какой-либо страницы сайта…

Дим, я не брал код с твоего сайта, поэтому не знаю на какой он там странице, он давно у меня в файлах от тебя был, может ты мне его в личку присылал, может на сайте каком выкладывал, не помню я источник…

Ссылку твою удалять не буду. Более того, добавил её в тот пост с кодом.


ЮMoney:41001419691823 | WMR:126292472390

 

Ответить

Kirigant

Дата: Среда, 29.02.2012, 18:26 |
Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 34


Репутация:

0

±

Замечаний:
0% ±


Alex_ST, Serge_007, очень интересные функции. Но хотелось бы спросить:
1. Чем отличаются функция представленная Alex_ST, от функции представленной Serge_007;
2. Пожалуйста авторы если не трудно выложите примеры использования данных функций в Excel, а то не получается разобраться.


«Все следует делать настолько простым, насколько это возможно, но не проще.»

 

Ответить

Alex_ST

Дата: Четверг, 01.03.2012, 17:07 |
Сообщение № 8

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3176


Репутация:

604

±

Замечаний:
0% ±


2003

Kirigant, а вы статью Дмитрия по ссылке в этом посте Сергея читали?
Там же всё разжёвано…
Просто то, что выкладывал я, отлавливает только точные совпадения, а макрос Дмитрия кроме того ещё и условия типа больше, больше и равно, меньше, меньше и равно.
Кроме того Дмитрий добавил ещё и возможность унификации полученного списка (получения в списке только уникальных значений).



С уважением,
Алексей
MS Excel 2003 — the best!!!

Сообщение отредактировал Alex_STЧетверг, 01.03.2012, 17:08

 

Ответить

Kirigant

Дата: Среда, 07.03.2012, 11:19 |
Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 34


Репутация:

0

±

Замечаний:
0% ±


Alex_ST я как-то пропустил ссылку на другой форум. smile Спасибо за напоминание, действительно там все расписано. Разобрался!


«Все следует делать настолько простым, насколько это возможно, но не проще.»

Сообщение отредактировал KirigantСреда, 07.03.2012, 11:20

 

Ответить

О том, как соединить текст из разных ячеек на основании условий.

Очень часто при работе с выгрузками данных из баз приходится упорядочивать и систематизировать информацию, соединять несколько текстов в один.

Например, существует перечень поставщиков сока для крупной компании. У каждого поставщика имеется несколько наименований продукции.

Поставщик Наименование сока
ООО «Крошка-Морошка» «Сок Ванили»
ООО «Икар-Макар» «Ореховый настой»
ООО «Крошка-Морошка» «Апельсинка»
ООО «Крошка-Морошка» Морс «Старый Ельник»
ООО «Крошка-Морошка» «Тыквовый»
ООО «Крошка-Морошка» «Огуречный с сиропом»
ООО «Икар-Макар» «Яблочный с мякотью»
ООО «Икар-Макар» «Груша-дичка»
ПАО «Старгарден» «Морс из клюквы»
ООО «Крошка-Морошка» Сок «Натуральный ананас»
ПАО «Старгарден» Напиток газированный «Лаванда»
ООО «Крошка-Морошка» Настой морошки
ПАО «Старгарден» Напиток газированный «Абрикос»

Нам необходимо выбрать и записать в одну строку все названия продукции, относящиеся к определенному поставщику, соединить их.соединение текста в эксель

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

Чтобы добавить макрос, следует выполнить следующие действия:

Код макроса VBA :

Function Scepka(DiapazonScepki As Range, DiapazonPoiska As Range, Uslovie As String)

Dim Delitel As String, i As Long ,  OutText As String

‘назначаем переменные для работы макроса DiapazonScepki — это диапазон с текстом, который следует сцепить; DiapazonPoiska – это диапазон условий для сравнения; Uslovie – это то условие, которое мы ищем; Delitel – символ делителя.

Delitel = «, » ‘указываем разделитель (символ, который будет разделять сцепленный текст, можно поставить пробел или пустоту «» – тогда текст сольется в одно слово)

If DiapazonPoiska.Count <> DiapazonScepki.Count Then

Scepka = CVErr(xlErrRef)

Exit Function

End If  ‘если диапазоны с данными для проверки и для сцепки отличаются по длине – функция выдает ошибку и закрывается

For i = 1 To DiapazonPoiska.Cells.Count

If DiapazonPoiska.Cells(i) Like Uslovie And Len(DiapazonScepki.Cells(i)) > 0 Then OutText = OutText & DiapazonScepki.Cells(i) & Delitel

Next i  ‘сверяем ячейки между собой и присваиваем переменной OutText подходящие по условиям текстовые значения. Для точного совпадения оператор Like следует заменить на знак «=».

Scepka = Left(OutText, Len(OutText) — Len(Delitel))

End Function

Теперь когда функция условной сцепки текста добавлена в книгу Excel при помощи макроса , ее можно использовать для обработки текста следующим образом:

Содержание

  1. Как сцепить несколько значений в одну ячейку по критерию? СцепитьЕсли
  2. Склеивание текста по условию
  3. Способ 0. Формулой
  4. Способ 1. Макрофункция склейки по одному условию
  5. Способ 2. Сцепить текст по неточному условию
  6. Способ 3. Макрофункция склейки текста по двум условиям
  7. Способ 4. Группировка и склейка в Power Query

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

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

Получить такую:

Стандартными функциями это сделать весьма проблематично, т.к. заранее неизвестно сколько будет этих оценок и фамилий. . 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 сам поймет, что требуется обработка массива ячеек.

А для пользователей 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 = «=|<>|=>|>=| | 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 » «» 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 » «» 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 ) -создать стандартный модуль(InsertModule) и в него вставить скопированный текст. После чего функцию СцепитьЕсли можно будет вызвать из Диспетчера функций( Shift + F3 ), отыскав её в категории Определенные пользователем (User Defined Functions) .
Синтаксис записи в ячейку листа:
=СцепитьЕсли( A2:A20 ; A2 ; B2:B20 ;»-«;0)

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

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

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

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

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

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

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

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

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

Источник

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

Про то, как можно быстро склеивать текст из нескольких ячеек в одну и, наоборот, разбирать длинную текстовую строку на составляющие я уже писал. Теперь же давайте рассмотрим близкую, но чуть более сложную задачу — как склеивать текст из нескольких ячеек при выполнении определенного заданного условия.

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

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

Способ 0. Формулой

Не очень изящный, зато самый простой способ. Можно написать несложную формулу, которая будет проверять отличается ли компания в очередной строке от предыдущей. Если не отличается, то приклеиваем через запятую очередной адрес. Если отличается, то «сбрасываем» накопленное, начиная заново:

Минусы такого подхода очевидны: из всех ячеек полученного дополнительного столбца нам нужны только последние по каждой компании (желтые). Если список большой, то чтобы их быстро отобрать придется добавить еще один столбец, использующий функцию ДЛСТР (LEN) , проверяющий длину накопленных строк:

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

Способ 1. Макрофункция склейки по одному условию

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

Если теперь вернуться в 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. Макрофункция склейки текста по двум условиям

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

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

Способ 4. Группировка и склейка в Power Query

Решить проблему можно и без программирования на VBA, если использовать бесплатную надстройку Power Query. Для Excel 2010-2013 ее можно скачать здесь, а в Excel 2016 она уже встроена по умолчанию. Последовательность действий будет следующей:

Power Query не умеет работать с обычными таблицами, поэтому первым шагом превратим нашу таблицу в «умную». Для этого ее нужно выделить и нажать сочетание Ctrl + T или выбрать на вкладке Главная — Форматировать как таблицу (Home — Format as Table) . На появившейся затем вкладке Конструктор (Design) можно задать имя таблицы (я оставил стандартное Таблица1):

Теперь загрузим нашу таблицу в надстройку Power Query. Для этого на вкладке Данные (если у вас Excel 2016) или на вкладке Power Query (если у вас Excel 2010-2013) жмем Из таблицы (Data — From Table) :

В открывшемся окне редактора запросов выделяем щелчком по заголовку столбец Компания и сверху жмем кнопку Группировать (Group By) . Вводим имя нового столбца и тип операции в группировке — Все строки (All Rows) :

Жмем ОК и получаем для каждой компании мини-таблицу сгруппированных значений. Содержимое таблиц хорошо видно, если щелкать левой кнопкой мыши в белый фон ячеек (не в текст!) в получившемся столбце:

Теперь добавим еще один столбец, где с помощью функции склеим через запятую содержимое столбцов Адрес в каждой из мини-таблиц. Для этого на вкладке Добавить столбец жмем Пользовательский столбец (Add column — Custom column) и в появившемся окне вводим имя нового столбца и формулу сцепки на встроенном в Power Query языке М:

Обратите внимание, что все М-функции регистрочувствительные (в отличие от Excel). После нажатия на ОК получаем новый столбец со склееными адресами:

Осталось удалить ненужный уже столбец ТаблАдресов (правой кнопкой мыши по заголовку — Удалить столбец) и выгрузить результаты на лист, нажав на вкладке Главная — Закрыть и загрузить (Home — Close and load) :

Важный нюанс : в отличие от предыдущих способов (функций), таблицы из Power Query не обновляются автоматически. Если в будущем произойдут какие-либо изменения в исходных данных, то нужно будет щелкнуть правой кнопкой в любое место таблицы результатов и выбрать команду Обновить (Refresh) .

Источник

Понравилась статья? Поделить с друзьями:
  • Макрос сцепить диапазон ячеек в excel
  • Макрос суммеслимн в excel
  • Макрос сумма прописью в рублях в excel
  • Макрос сумма прописью в excel скачать бесплатно
  • Макрос сумма прописью в excel без надстройки