Здравствуйте,
Я столкнулся с необходимостью сцепления данных по нескольким условиям с учетом операторов сравнения (<, >, =) и спецсимволов подстановок (*, #, ?), однако в просторах интернета я смог найти
1. Сцепление по одному условию, но с оператором сравнения
2. Сцепление по нескольким условиям, без операторов сравнения
Помогите пожалуйста внести еще один критерий в первую функцию.
Я столкнулся с необходимостью сцепления данных по нескольким условиям с учетом операторов сравнения (<, >, =) и спецсимволов подстановок (*, #, ?), однако в просторах интернета я смог найти
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 |
Помогите пожалуйста внести еще один критерий в первую функцию.