Как сцепить несколько значений в одну ячейку по критерию? СцепитьЕсли
Все чаще вижу на разных форумах вопросы типа: Есть таблица, в одном столбце фамилии, в другом оценки(виды работ и т.д.). Как сцепить в одной ячейке для каждой фамилии только принадлежащие ей оценки? Стандартными функциями это сделать весьма проблематично, т.к. заранее неизвестно сколько будет этих оценок. Вот и решил написать небольшую функцию на VBA, которая решает данную проблему.
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
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Для применения функции в своем файле достаточно создать стандартный модуль(как это сделать написано здесь) и просто вставить приведенный код. После этого в диспетчере функций появиться новая категория(если до этого её не было) — Определенные пользователем. В ней эта функция — СцепитьЕсли.
По принципу работы функция похожа на стандартную СУММЕСЛИ. Указываете диапазон значений, критерий и диапазон значений для сцепления. Символ для разделения слов указывать необязательно.
По умолчанию Разделитель слов — пробел, но можно задать любой другой символ/символы.
Диапазон — диапазон с критериями(указывается один столбец)
Критерий — критерий. Собственно то, с чем сравниваем. Может содержать символы подстановки — * и ?. Просматривается Диапазон. Можно указать символы сравнения с самим критерием сравнения(<>"", <23, >0, "<>"&A1 и т.п.)
Диапазон_сцепления — из этого диапазона берется значение для сцепления, если значение в аргументе Диапазон совпадает с аргументом Критерий(указывается один столбец)
БезПовторов — если указать 1 или ИСТИНА, то в резульате получится строка, в которой нет одинковых значений. Если указать 0 или ЛОЖЬ, то будут выведены все значения. По умолчанию значение ЛОЖЬ.
Примечание: для работы функции должны быть разрешены макросы.
Tips_Macro_CoupleIf.xls (49,0 KiB, 2 624 скачиваний)
Также см.:
→Couple_Cells - быстрое сцепление диапазона ячеек
→Что такое функция пользователя(UDF)?
(диспетчер функций), расположенный чуть левее строки формул или 
рис.1
рис.2
).
