'---------------------------------------------------------------------------------------
' 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