Я столкнулся с необходимостью сцепления данных по нескольким условиям с учетом операторов сравнения (<, >, =) и спецсимволов подстановок (*, #, ?), однако в просторах интернета я смог найти 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
Помогите пожалуйста внести еще один критерий в первую функцию.
Я обращался к автору, Пример здесь необязателен, т.к. мне нужна функция сцепления по нескольким (мин. 2) условиям с поддержкой операторов сравнения и спецсимволов подстановок
Вторая функция моя. Доработанный ее вариант, с возможностью использования операторов сравнения ('>='; '<='; '<>')
Код
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м и более критериям"
Sanja, Подскажите пожалуйста: если в ряду просматриваемого массива присутствует дробное число (например с десятичным знаком), Ваш макрос это число не воспринимает – возможно это исправить? Так же интересует возможность использования в функции оператора "не равно" с текстом ("><*текст*") , использование которого прекрасно работает в функции СЧЁТЕСЛИМН. Можете помочь? пример прикладываю.
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&
Dim iVal, iZn$, iStr$
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
iVal = rngU.Parent.Cells(rngU(I).Row, Conditions(J).Column).Value
Select Case True
Case IsNumeric(iVal)
iVal = Replace(iVal, ",", ".")
iZn = IIf(WorksheetFunction.And(Left(Conditions(J + 1), 1) <> ">", Left(Conditions(J + 1), 1) <> "<"), "=", vbNullString)
iStr = iVal & iZn & Conditions(J + 1)
arrFlag(Int(J / 2)) = Application.Evaluate(iStr)
Case Else
iStr = IIf(Left(Conditions(J + 1), 1) = "<", Mid(Conditions(J + 1), 3, Len(Conditions(J + 1)) - 2), Conditions(J + 1))
arrFlag(Int(J / 2)) = IIf(Left(Conditions(J + 1), 1) = "<", Not (iVal Like iStr), iVal Like iStr)
End Select
Next
If WorksheetFunction.And(arrFlag) = True Then СЦЕПИТЬЕСЛИМН = IIf(СЦЕПИТЬЕСЛИМН <> Empty, СЦЕПИТЬЕСЛИМН & ", " & cl(I, 1), cl(I, 1))
Next
End Function