Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Функция (UDF) "СцепитьЕсли" - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Функция (UDF) "СцепитьЕсли" (СцепитьЕсли() - это аналог СУММЕСЛИ(), но для текстов)
Функция (UDF) "СцепитьЕсли"
Alex_ST Дата: Четверг, 26.08.2010, 11:29 | Сообщение № 1
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3108
Репутация: 586 ±
Замечаний: 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
 
Ответить
Сообщение=======================================================
Функция (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]

Автор - Alex_ST
Дата добавления - 26.08.2010 в 11:29
Serge_007 Дата: Пятница, 10.09.2010, 14:34 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 13305
Репутация: ±
Замечаний: ±

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

[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]

Источник


Яндекс-деньги:41001419691823 | WMR:126292472390
 
Ответить
СообщениеАналогичная функция:

[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]

Источник

Автор - Serge_007
Дата добавления - 10.09.2010 в 14:34
The_Prist Дата: Вторник, 10.05.2011, 08:09 | Сообщение № 3
Группа: Друзья
Ранг: Участник
Сообщений: 84
Репутация: 22 ±
Замечаний: 0% ±

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


Errare humanum est, stultum est in errore perseverare
 
Ответить
СообщениеСергей, привет.
А разьве ссылку на источник не надо указыать? :-) Я вроде делал пометку на сайте. Нехорошо получается...

Автор - The_Prist
Дата добавления - 10.05.2011 в 08:09
Serge_007 Дата: Вторник, 10.05.2011, 10:30 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 13305
Репутация: ±
Замечаний: ±

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

Привет Дим.
Посмотри вторую строку:
Quote
' Author : The_Prist(Дмитрий); http://www.excel-vba.ru
Мало того что ссылка на источник, так ещё и автор указан smile


Яндекс-деньги:41001419691823 | WMR:126292472390
 
Ответить
Сообщение
Quote (The_Prist)
Сергей, привет.
А разьве ссылку на источник не надо указыать? :-) Я вроде делал пометку на сайте. Нехорошо получается...

Привет Дим.
Посмотри вторую строку:
Quote
' Author : The_Prist(Дмитрий); http://www.excel-vba.ru
Мало того что ссылка на источник, так ещё и автор указан smile

Автор - Serge_007
Дата добавления - 10.05.2011 в 10:30
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
 
Ответить
Сообщение
Quote (Serge_007)
Мало того что ссылка на источник, так ещё и автор указан
Сергей, то, что в коде указан автор и его сайт не является ссылкой на источник. Ссылка на источник выглядит как ссылка на статью(саму ссылку можешь потом удалить из моего поста - это для демонстрации того, как ссылка выглядит). Я её не вижу :-)
Мое мнение: раз уж листинг кода полностью берётся с какой-либо страницы сайта, то и ссылка должна быть на страницу первоисточника.
Конечно, мое мнение может не совпадать с твоим и спорить не собираюсь. Это лишь высказывание мнения.

Автор - The_Prist
Дата добавления - 10.05.2011 в 10:58
Serge_007 Дата: Вторник, 10.05.2011, 11:41 | Сообщение № 6
Группа: Админы
Ранг: Местный житель
Сообщений: 13305
Репутация: ±
Замечаний: ±

Excel 2010
Quote (The_Prist)
...раз уж листинг кода полностью берётся с какой-либо страницы сайта...

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

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


Яндекс-деньги:41001419691823 | WMR:126292472390
 
Ответить
Сообщение
Quote (The_Prist)
...раз уж листинг кода полностью берётся с какой-либо страницы сайта...

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

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

Автор - Serge_007
Дата добавления - 10.05.2011 в 11:41
Kirigant Дата: Среда, 29.02.2012, 18:26 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 34
Репутация: 0 ±
Замечаний: 0% ±

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


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

Автор - Kirigant
Дата добавления - 29.02.2012 в 18:26
Alex_ST Дата: Четверг, 01.03.2012, 17:07 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3108
Репутация: 586 ±
Замечаний: 0% ±

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



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


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

Автор - Alex_ST
Дата добавления - 01.03.2012 в 17:07
Kirigant Дата: Среда, 07.03.2012, 11:19 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 34
Репутация: 0 ±
Замечаний: 0% ±

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


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

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

Автор - Kirigant
Дата добавления - 07.03.2012 в 11:19
Мир MS Excel » Вопросы и решения » Готовые решения » Функция (UDF) "СцепитьЕсли" (СцепитьЕсли() - это аналог СУММЕСЛИ(), но для текстов)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2020 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!