Страницы: 1
RSS
Сцепить по нескольким критериям, добавить критерий в функцию Сцепитьесли
 
Здравствуйте Уважаемые мэтры VBA. прошу вашей помощи в решении проблемы. На форуме нашел функцию, разработанную уважаемым The_Prist, СцепитьЕсли Я попробовал добавить еще один критерий и выскочила ошибка. Помогите пожалуйста внести еще один критерий в функцию. =СцепитьЕсли(данные!$D$1:$D$25;"Исправен";данные!$E$1:$E$25;"Мирный";данные!$D$1:$D$25;",")  Или может есть еще способ?

Код
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
 
какой должен быть результат покажите, а то с ваших попыток непонятно что вы хотите сцепить.
 
Dima S,доброго времени. Вопрос этот связан с сортировкой чтоб в одной ячейке были перечислены машины которые исправны в городе ленске (свидом работы который они производят), в другом столбце неисправны в г. Ленске (с причиной поломки), тоже самое по городу Мирной
 
Цитата
alex1210 написал: ...чтоб в одной ячейке были перечислены...
Смешались в кучу кони, люди... А оно вам надо - потом все это разгребать без гаранта на успех?! Мо быть простенькая сводная с разбивкой по городам и испр./не испр.?!. ;)
ps См. "Приемы" - http://www.planetaexcel.ru/techniques/8/130/
"Ctrl+S" - достойное завершение ваших гениальных мыслей!.. ;)
 
Данная функция работает только с одним диапазоном критериев, поэтому сначала нужно сформировать столбец с критериями.
Обращайте внимание на написание слов - "Исправен " <> "Исправен"
также посмотрите на другой вариант решения на вкладке Сводная - по-моему так более читабельно.
Изменено: Dima S - 19.02.2017 16:59:26
 
Вся беда, господа, в том что формы отчетности присылает Москва. я могу лишь делать промежуточные скрытые листа и проводить там манипуляции. Но в конечном итоге все должно прописаться именно в тех строках которые требует Столица
 
Не такая универсальная как у Дмитрия (The_Prist), нельзя использовать операторы сравнения, но без ограничения на количество условий
И да
Цитата
Dima S написал: Обращайте внимание на написание слов - "Исправен " <> "Исправен"

Код
Function СЦЕПИТЬЕСЛИМН(rngU As Range, ParamArray Conditions()) As String
'rngU - диапазон сцепления
'Conditions() - массив ПАР значений вида: Диапазон_Условий1;Условие1;Диапазон_Условий2;Условие2...Диапазон_УсловийN;УсловиеN, обязательный
'               должен иметь хотя-бы одну пару значений.
'Разделителем найденных значений является ', ' (запятая с пробелом)
'Все диапазоны должны состоять из одного столбца и иметь равное кол-во строк
Dim cl()
Dim arrFlag() As Boolean
Dim I&, J&
On Error Resume Next
cl = rngU.Value
For I = 1 To UBound(cl)
    ReDim arrFlag(Int(UBound(Conditions) / 2))
    For J = LBound(Conditions) To UBound(Conditions) Step 2
        If rngU.Parent.Cells(rngU(I).Row, Conditions(J).Column).Value Like Conditions(J + 1) Then
            arrFlag(Int(J / 2)) = True
        End If
    Next
    If WorksheetFunction.And(arrFlag) = True Then
        If СЦЕПИТЬЕСЛИМН <> Empty Then
            СЦЕПИТЬЕСЛИМН = СЦЕПИТЬЕСЛИМН & ", " & cl(I, 1)
        Else
            СЦЕПИТЬЕСЛИМН = cl(I, 1)
        End If
    End If
Next
End Function
Изменено: Sanja - 19.02.2017 17:10:05
Согласие есть продукт при полном непротивлении сторон
 
Sanja,Доброго времени, Я вот всегда поражался, как у Вас всё так гениально получается, спасибо большое.Dima S, спасибо за подсказку, тоже интересное решение. Блин надо научиться составлять сводные. Сколько не пытаюсь вечно какой то ковардак получается, и материалов кучу просмотрел, не получается))) Ещё раз спасибо всем огромное, Sanja, Вам отдельное спасибо, очередной раз выручили)))
 
Цитата
alex1210 написал: как у Вас всё так получается
Спасибо  :). Годы тренировок. В т.ч. на Планете
Согласие есть продукт при полном непротивлении сторон
 
Sanja, ещё раз спасибо)))Выскакиваю, у нас уже 23.31, а ещё на работе)))
Страницы: 1
Наверх