Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Сцепить по нескольким критериям
 
Здравствуйте,

Я столкнулся с необходимостью сцепления данных по нескольким условиям с учетом операторов сравнения (<, >, =) и спецсимволов подстановок (*, #, ?), однако в просторах интернета я смог найти
1. Сцепление по одному условию, но с оператором сравнения
2. Сцепление по нескольким условиям, без операторов сравнения
   
Код
Option Compare TextOption Explicit
'---------------------------------------------------------------------------------------
' Procedure :   СцепитьЕсли
' Author    :   The_Prist(Щербаков Дмитрий)

' Purpose   :   https://www.excel-vba.ru/chto-umeet-excel/kak-scepit-neskolko-znachenij-v-odnu-yachejku-po-kriteriyu...
'---------------------------------------------------------------------------------------
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

Код
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

Помогите пожалуйста внести еще один критерий в первую функцию.
Изменено: kiesza - 4 Сен 2018 09:54:32
 
в коде написан автор и его сайт почему не обратится к нему и при этом совсем не понятно без примера в файле что вы хотите сцепить и по каким условиям
Лень двигатель прогресса, доказано!!!
 
Цитата
Сергей написал:
в коде написан автор и его сайт почему не обратится к нему и при этом совсем не понятно без примера в файле что вы хотите сцепить и по каким условиям
Я обращался к автору,
Пример здесь необязателен, т.к. мне нужна функция сцепления по нескольким (мин. 2) условиям с поддержкой операторов сравнения и спецсимволов подстановок
 
Цитата
kiesza написал:
Пример здесь необязателен
ну нет дак нет ждите провидца  
Лень двигатель прогресса, доказано!!!
 
OFF Сергей,  :D  :D  :D  :D  сущность в виде гномика)))
Цитата
Сергей написал:
провидца  
Изменено: a.i.mershik - 4 Сен 2018 09:53:54
 
Вторая функция моя. Доработанный ее вариант, с возможностью использования операторов сравнения ('>='; '<='; '<>')
Код
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 Left(Conditions(J + 1), 1) = ">" Or Left(Conditions(J + 1), 1) = "<" Then
            If Application.Evaluate(rngU.Parent.Cells(rngU(I).Row, Conditions(J).Column).Value & Conditions(J + 1)) Then
                If Err = 0 Then
                    arrFlag(Int(J / 2)) = True
                Else
                    Err.Clear
                End If
            End If
        ElseIf 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
Согласие есть продукт при полном непротивлении сторон.
 
Цитата
kiesza: Сцепление по одному условию, но с оператором сравнения
сцепите все условия в одно (столбец-ключ) и спокойно  используйте «СцепитьЕсли»  ;)
универсальный совет для сотен вопросов типа "ВПР по 2м и более критериям"
Изменено: Jack Famous - 4 Сен 2018 11:05:05
«Тот, кто несет фонарь, спотыкается чаще, чем тот, кто идет следом.»
Иоганн Пауль Фридрих Рихтер
Страницы: 1
Читают тему (гостей: 1)
Наверх