Доброго времени Уважаемые Форумчане! Прошу помочь доработать функцию сцепки с несколькими условиями, чтобы она сцепляла без повторов. Заранее благодарен
Код |
---|
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 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 Next If WorksheetFunction.And(arrFlag) = True Then If СЦЕПИТЬЕСЛИМН <> Empty Then СЦЕПИТЬЕСЛИМН = СЦЕПИТЬЕСЛИМН & " " & cl(I, 1) Else СЦЕПИТЬЕСЛИМН = cl(I, 1) End If End If Next End Function |