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

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

 Delimeter = Chr(10)

'проходим по всем ячейкам, проверяем условие и собираем текст в переменную 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

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

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

Delimiter = vbNewLine

{=ПОДСТАВИТЬ(ПОДСТАВИТЬ(ОБЪЕДИНИТЬ(", ";1;ЕСЛИ(Таблица1[@[barren]:[temperate]]="x";Таблица1[[#Заголовки];[barren]:[temperate]];));"0, ";"");", 0";"")}
 

{=ПОДСТАВИТЬ(ПОДСТАВИТЬ(ОБЪЕДИНИТЬ(", ";1;ЕСЛИ(($C$3:$C$59)=$R3;E$3:E$59;""));"0, ";"");", 0";"")}
 

Option Compare Text

Function СКЛ_ЯЧ_1(Текст As Range, Диапазон As Range, Ключ As String, Сумма As Byte)
    Dim Delimeter As String, i As Long
    Delimeter = ", " 'символы-разделители (можно заменить на пробел или ; и т.д.)
     
    'если диапазоны проверки и склеивания не равны друг другу - выходим с ошибкой
    If Диапазон.Count <> Текст.Count Then
        СКЛ_ЯЧ_1 = CVErr(xlErrRef)
        Exit Function
    End If
     k = 0
    'проходим по все ячейкам, проверяем условие и собираем текст в переменную OutText
    For i = 1 To Диапазон.Cells.Count
        If Диапазон.Cells(i) Like Ключ And Len(Текст.Cells(i)) > 0 Then
            If Сумма = 0 Then
                OutText = OutText & Текст.Cells(i) & Delimeter
            ElseIf Сумма = 1 Then
                OutText = OutText + Текст.Cells(i)
            ElseIf Сумма = 2 Then
'                Если нужно игнорировать ноли или пустые ячейки
'                If OutText = 0 Or OutText = "" Then OutText = 1
                If k = 0 Then OutText = 1
                OutText = OutText * Текст.Cells(i)
               
            End If
            k = 1
        End If
    Next i
        If Сумма = 0 Then
            СКЛ_ЯЧ_1 = Left(OutText, Len(OutText) - Len(Delimeter))
        Else
            СКЛ_ЯЧ_1 = OutText
        End If
    'выводим результаты без последнего разделителя
'    СКЛ_ЯЧ_1 = Left(OutText, Len(OutText) - Len(Delimeter))
End Function


Function СКЛ_ЯЧ_2(Текст As Range, Диапазон1 As Range, Ключ1 As String, Диапазон2 As Range, Ключ2 As String, Сумма As Byte)
    Dim Delimeter As String, i As Long
    Delimeter = ", " 'символы-разделители (можно заменить на пробел или ; и т.д.)
     
    'если диапазоны проверки и склеивания не равны друг другу - выходим с ошибкой
    If Диапазон1.Count <> Текст.Count Or Диапазон2.Count <> Текст.Count Then
        СКЛ_ЯЧ_2 = CVErr(xlErrRef)
        Exit Function
    End If
     k = 0
    'проходим по все ячейкам, проверяем все условия и собираем текст в переменную OutText
    For i = 1 To Диапазон1.Cells.Count
        If Диапазон1.Cells(i) Like Ключ1 And Диапазон2.Cells(i) Like Ключ2 Then
            If Сумма = 0 Then
                OutText = OutText & Текст.Cells(i) & Delimeter
            ElseIf Сумма = 1 Then
                OutText = OutText + Текст.Cells(i)
            ElseIf Сумма = 2 Then
'                Если нужно игнорировать ноли или пустые ячейки
'                If OutText = 0 Or OutText = "" Then OutText = 1
                If k = 0 Then OutText = 1
                OutText = OutText * Текст.Cells(i)
            End If
            k = 1
        End If
    Next i
     
    'выводим результаты без последнего разделителя
    If Сумма = 0 Then
        СКЛ_ЯЧ_2 = Left(OutText, Len(OutText) - Len(Delimeter))
    Else
        СКЛ_ЯЧ_2 = OutText
    End If
    
End Function

Function СЦЕПИТЬЕСЛИ(СцепитьТекст As Range, Диапазон As Range, Условие As String)
    Dim Delimeter As String, i As Long
    Delimeter = ", "
    If Диапазон.Count <> СцепитьТекст.Count Then
        СЦЕПИТЬЕСЛИ = CVErr(xlErrRef)
        Exit Function
    End If
    For i = 1 To Диапазон.Cells.Count
        If Диапазон.Cells(i) = Условие And Len(Диапазон.Cells(i)) > 0 Then OutText = OutText & IIf(IsError(СцепитьТекст.Cells(i)), "", СцепитьТекст.Cells(i)) & Delimeter
    Next i
    СЦЕПИТЬЕСЛИ = Left(OutText, Len(OutText) - Len(Delimeter))
End Function
Function СЦЕПИТЬЕСЛИМН(СцепитьТекст As Range, Диапазон1 As Range, Условие1 As String, Диапазон2 As Range, Условие2 As String)
    Dim Delimeter As String, i As Long
    Delimeter = ", "
    If Диапазон1.Count <> СцепитьТекст.Count Or Диапазон2.Count <> СцепитьТекст.Count Then
        СЦЕПИТЬЕСЛИМН = CVErr(xlErrRef)
        Exit Function
    End If
    For i = 1 To Диапазон1.Cells.Count
        If Диапазон1.Cells(i) = Условие1 And Диапазон2.Cells(i) = Условие2 Then
            OutText = OutText & IIf(IsError(СцепитьТекст.Cells(i)), "", СцепитьТекст.Cells(i)) & Delimeter
        End If
    Next i
    СЦЕПИТЬЕСЛИМН = Left(OutText, Len(OutText) - Len(Delimeter))
End Function

="Исполнительная схема №"&$B$3&"."&$C$3&"."&L12&" от "&ТЕКСТ(F12;"ДД.ММ.ГГГГ")&"г.; протокол испытаний (определение коэффициента уплотнения) №П-457.АК/24 от 03.07.2024, №П-481.АК/24 от 09.07.2024, №П-494.АК/24 от 12.07.2024, №П-554.АК/24 от 30.07.2024"