Как сцепить несколько значений в одну ячейку по критерию? СцепитьЕсли
Все чаще вижу на разных форумах вопросы типа: Есть таблица, в одном столбце фамилии, в другом оценки(виды работ и т.д.). Как сцепить в одной ячейке для каждой фамилии только принадлежащие ей оценки? Или собрать в одну ячейку через запятую фамилии всех сотрудников одного отдела, но все сотрудники идут вразнобой. Т.е. из такой таблицы:
Решение стандартными формулами Стандартными функциями это сделать весьма проблематично, т.к. заранее неизвестно сколько будет этих оценок и фамилий.. Microsoft работает над усовершенствованием Excel и теперь стало возможным сделать это и стандартными функциями. Правда, с небольшими ограничениями: сделать это могут только пользователи Excel 2019 и выше или Office 365 по подписке. В итоге счастливые обладатели новейших версий могут использовать достаточно несложные формулы: =ОБЪЕДИНИТЬ("; ";1;ФИЛЬТР(B2:B20;A2:A20=A2;"")) =TEXTJOIN("; ",1,FILTER(B2:B20,A2:A20=A2,""))
Аргументы функции:
("; ") - символ(или несколько символов), которым необходимо объединять найденные значения
(A2:A20) - диапазон, в котором искать критерий
(A2) - критерий. Значение, на основании которого необходимо сцеплять значения. Значение просматривается в диапазоне значений(A2:A20)
(B2:B20) - из этого диапазона берется значение для сцепления, если значение напротив в диапазонe(A2:A20) совпадает с искомым значением A2
Для любителей "старой школы" можно вместо функции ФИЛЬТР(FILTER) использовать стандартную ЕСЛИ(IF): =ОБЪЕДИНИТЬ("; ";1;ЕСЛИ(A2:A20=A2;B2:B20;"")) =TEXTJOIN("; ",1,IF(A2:A20=A2,B2:B20,"")) так же это можно использовать в Excel 2019 в случае, если функция ФИЛЬТР отсутствует - да, может быть и такое, хоть Microsoft и пишет, что она там поддерживается
Аргументы точно такие же, как в формуле выше. Правда эта формула вводится в ячейку как формула массива(т.е. одновременным нажатием трех клавиш Ctrl+Shift+Enter). Хотя в самых новых версия(а-ля 365) вводить тремя клавишами уже не обязательно - Excel сам поймет, что требуется обработка массива ячеек.
Объединяем текст по критерию при помощи написания собственной UDF - СцепитьЕсли
А для пользователей Excel 2016 и ниже я написал небольшую функцию пользователя на VBA, которая решает данную проблему. Так же подобную функцию называют "многоразовый ВПР", потому что она по критерию возвращает ВСЕ значения для этого критерия, а не только первое.
'---------------------------------------------------------------------------------------' Author : The_Prist(Щербаков Дмитрий)' Профессиональная разработка приложений для MS Office любой сложности' Проведение тренингов по MS Excel' http://www.excel-vba.ru' Purpose:'---------------------------------------------------------------------------------------Function СцепитьЕсли(ByRef Диапазон As Range, ByVal Критерий AsString, ByRef Диапазон_сцепления As Range, _
Optional Разделитель AsString = " ", _
Optional БезПовторов AsBoolean = False) AsStringDim li AsLong, sStr AsString, avItem, avDateArr(), avRezArr(), lUBnd AsLongIf Диапазон.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)
EndIfElseReDim avDateArr(1, 1): ReDim avRezArr(1, 1)
avDateArr(1, 1) = Диапазон.Value
avRezArr(1, 1) = Диапазон_сцепления.Value
EndIf
lUBnd = UBound(avDateArr, 1)
'Определяем вхождение операторов сравнения в КритерийDim objRegExp AsObject, objMatches AsObjectSet objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Global = False: objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<"Set objMatches = objRegExp.Execute(Критерий)
'Если есть вхожденияIf objMatches.Count > 0 ThenDim sStrMatch AsString
sStrMatch = objMatches.Item(0)
Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
If IsNumeric(Критерий) And Критерий <> ""Then
Критерий = CDbl(Критерий)
EndIfSelectCase sStrMatch
Case"="For li = 1 To lUBnd
If avDateArr(li, 1) = Критерий ThenIf Trim(avRezArr(li, 1)) <> ""Then _
sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
EndIfNext li
Case"<>"For li = 1 To lUBnd
If avDateArr(li, 1) <> Критерий ThenIf Trim(avRezArr(li, 1)) <> ""Then _
sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
EndIfNext li
Case">=", "=>"For li = 1 To lUBnd
If avDateArr(li, 1) >= Критерий ThenIf Trim(avRezArr(li, 1)) <> ""Then _
sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
EndIfNext li
Case"<=", "=<"For li = 1 To lUBnd
If avDateArr(li, 1) <= Критерий ThenIf Trim(avRezArr(li, 1)) <> ""Then _
sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
EndIfNext li
Case">"For li = 1 To lUBnd
If avDateArr(li, 1) > Критерий ThenIf Trim(avRezArr(li, 1)) <> ""Then _
sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
EndIfNext li
Case"<"For li = 1 To lUBnd
If avDateArr(li, 1) < Критерий ThenIf Trim(avRezArr(li, 1)) <> ""Then _
sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
EndIfNext li
EndSelectElse'Если нет вхожденияFor li = 1 To lUBnd
If avDateArr(li, 1) Like Критерий ThenIf Trim(avRezArr(li, 1)) <> ""Then _
sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
EndIfNext li
EndIfIf БезПовторов ThenDim oDict AsObject, sTmpStr
Set oDict = CreateObject("Scripting.Dictionary")
sTmpStr = Split(sStr, Разделитель)
OnErrorResumeNextFor li = LBound(sTmpStr) ToUBound(sTmpStr)
oDict.Add sTmpStr(li), sTmpStr(li)
Next li
sStr = ""
sTmpStr = oDict.keys
For li = LBound(sTmpStr) ToUBound(sTmpStr)
sStr = sStr & IIf(sStr <> "", Разделитель, "") & sTmpStr(li)
Next li
EndIf
СцепитьЕсли = sStr
EndFunction
'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
' Профессиональная разработка приложений для MS Office любой сложности
' Проведение тренингов по MS Excel
' http://www.excel-vba.ru
' Purpose:
'---------------------------------------------------------------------------------------
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
Чтобы правильно использовать приведенный код, необходимо сначала ознакомиться со статьей Что такое функция пользователя(UDF)?. Вкратце: скопировать текст кода выше, перейти в редактор VBA(Alt+F11) -создать стандартный модуль(Insert -Module) и в него вставить скопированный текст. После чего функцию СцепитьЕсли можно будет вызвать из Диспетчера функций(Shift+F3), отыскав её в категории Определенные пользователем (User Defined Functions). Синтаксис записи в ячейку листа: =СцепитьЕсли(A2:A20;A2;B2:B20;"; ";0)
По принципу работы функция похожа на стандартную СУММЕСЛИ. Указывается диапазон значений(где просматривать значение), критерий и диапазон значений для сцепления. Символ для разделения слов указывать необязательно.
Диапазон(A2:A20) - диапазон, в котором искать критерий(указывается один столбец). В данном случае это столбец с названиями отделов.
Критерий(A2) - критерий. Значение, на основании которого необходимо сцеплять значения. Значение просматривается в диапазоне, указанном аргументом Диапазон. Может содержать символы подстановки - * и ? и символы сравнения (<>"", <23, >0, "<>"&A1 и т.п.). Если при сравнении с заданным критерием значение в диапазоне(Диапазон) считается отвечающим условию, то значение из Диапазона_Сцепления добавляется к результату с выбранным разделителем.
Диапазон_сцепления(B2:B20) - из этого диапазона берется значение для сцепления, если значение в аргументе Диапазон отвечает условию, заданному аргументом Критерий(указывается один столбец). Если в Диапазоне значение 5-ой строки совпадает с критерием, то из Диапазона_Сцепления будет взято так же значение из 5-ой строки этого диапазона и сцеплено с результатом.
Разделитель("; ") - По умолчанию пробел, но можно задать любой другой символ или группу символов. Если необходимо в качестве разделителя использовать символ переноса на новую строку, то его следует записать как функцию: СИМВОЛ(10) (CHAR(10)). Для отображения переноса в ячейке с функцией необходимо для ячейки включить отображение переносов строк(вкладка Главная -группа Выравнивание -Переносить текст).
БезПовторов - если указать 1 или ИСТИНА(TRUE), то в результате получится строка, в которой нет одинаковых значений. Если указать 0 или ЛОЖЬ(FALSE), то будут выведены все значения. По умолчанию значение ЛОЖЬ(FALSE), т.е. строка будет содержать все найденные значения, даже если они повторяются.
Объединяем текст по нескольким критериям при помощи UDF - СцепитьЕсли2
По многочисленным просьбам написал UDF, которая может объединять значения по нескольким условиям. Допускается до 4-х условий, но при наличии желания и небольших навыков можно расширить это число хоть до 100.
Основная функция - СцепитьЕсли2. Но она использует еще и вспомогательные функции для более удобного добавления новых критериев: GetArr, GetIntersectRange и Get_Match. Пояснения к каждой функции написаны в заголовках функций, так что понять, что делает какая из них не должно быть проблемой для тех, у кого появится желание доработать код.
'---------------------------------------------------------------------------------------' Author : Щербаков Дмитрий(The_Prist)' Профессиональная разработка приложений для MS Office любой сложности' Проведение тренингов по MS Excel' https://www.excel-vba.ru' info@excel-vba.ru' Purpose:'---------------------------------------------------------------------------------------OptionExplicitOptionCompare Text
Dim objRegExp AsObject'---------------------------------------------------------------------------------------' Purpose: Функция СцепитьЕсли2 объединяет строки по заданным условиям. Допускается указание до 4-х условий' Диапазон - диапазон, в котором просматривать условия(критерии)' Критерий - условие отбора. Ссылка на ячейку или значение. ' Может начинаться на операторы сравнения: =; <>; =>; >=; <=; =<; >; <' Диапазон_сцепления - диапазон из одной строки или столбца, из которого брать значения для объединения в одну строку' Разделитель - Символ или символы, который используется для объединения отобранных значений' БезПовторов - 1 или ИСТИНА(True) - в итоговую строку будут собраны только уникальные значения' Диапазон2,Критерий2 и т.д. - дополнительные связки Диапазон-Критерий. До 4-х'---------------------------------------------------------------------------------------Function СцепитьЕсли2(ByRef Диапазон As Range, ByVal Критерий, ByRef Диапазон_сцепления As Range, _
Optional Разделитель AsString = " ", Optional БезПовторов AsBoolean = False, _
OptionalByRef Диапазон2 As Range, OptionalByVal Критерий2, _
OptionalByRef Диапазон3 As Range, OptionalByVal Критерий3, _
OptionalByRef Диапазон4 As Range, OptionalByVal Критерий4) AsStringDim oDict AsObjectDim li AsLong, sStr AsString, avItem, avDateArr(), avRezArr(), lUBnd AsLongDim avDateArr2(), avDateArr3(), avDateArr4()
Dim rr As Range
Dim bCompare AsBoolean, IsR2 AsBoolean, IsR3 AsBoolean, IsR4 AsBooleanDim skey$, stxt$
Dim sTmpStr
Set oDict = CreateObject("Scripting.Dictionary")
oDict.comparemode = 1
'определяем, все ли связки Диапазон-Критерий указаны'далее проверяем только условия, для которых есть Диапазон и Критерий
IsR2 = Not IsMissing(Критерий2) AndNot Диапазон2 IsNothing
IsR3 = Not IsMissing(Критерий3) AndNot Диапазон3 IsNothing
IsR4 = Not IsMissing(Критерий4) AndNot Диапазон4 IsNothing'определяем вхождение диапазонов в рабочий диапазон'нужно, чтобы отсечь лишние строки/столбцы при указании полных строк и столбцов'Диапазон 1Set rr = GetIntersectRange(Диапазон)
If rr IsNothingThenExitFunctionEndIf
avDateArr = GetArr(rr)
'Диапазон СцепленияSet rr = GetIntersectRange(Диапазон_сцепления)
If rr IsNothingThenExitFunctionEndIf
avRezArr = GetArr(rr)
'Диапазон 2If IsR2 ThenSet rr = GetIntersectRange(Диапазон2)
If rr IsNothingThen
IsR2 = FalseElse
avDateArr2 = GetArr(rr)
EndIfEndIf'Диапазон 3If IsR3 ThenSet rr = GetIntersectRange(Диапазон3)
If rr IsNothingThen
IsR3 = FalseElse
avDateArr3 = GetArr(rr)
EndIfEndIf'Диапазон 4If IsR4 ThenSet rr = GetIntersectRange(Диапазон4)
If rr IsNothingThen
IsR4 = FalseElse
avDateArr4 = GetArr(rr)
EndIfEndIf'если диапазоны указаны горизонтально - разворачиваем в вертикальный массивIf Диапазон.Columns.Count > 1 And Диапазон.Rows.Count = 1 Then
avDateArr = Application.Transpose(avDateArr)
If IsR2 Then
avDateArr2 = Application.Transpose(avDateArr2)
EndIfIf IsR3 Then
avDateArr3 = Application.Transpose(avDateArr3)
EndIfIf IsR4 Then
avDateArr4 = Application.Transpose(avDateArr4)
EndIf
avRezArr = Application.Transpose(avRezArr)
EndIf
lUBnd = UBound(avDateArr, 1)
'Опрееделяем вхождение операторов сравнения в КритерийIf objRegExp IsNothingThenSet objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Global = False
objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<"EndIfFor li = 1 To lUBnd
bCompare = TrueIfNot Get_Match(Критерий, avDateArr(li, 1)) Then
bCompare = FalseEndIf'2 диапазон и критерийIf IsR2 And bCompare ThenIfNot Get_Match(Критерий2, avDateArr2(li, 1)) Then
bCompare = FalseEndIfEndIf'3 диапазон и критерийIf IsR3 And bCompare ThenIfNot Get_Match(Критерий3, avDateArr3(li, 1)) Then
bCompare = FalseEndIfEndIf'4 диапазон и критерийIf IsR4 And bCompare ThenIfNot Get_Match(Критерий4, avDateArr4(li, 1)) Then
bCompare = FalseEndIfEndIfIf bCompare Then
stxt = Trim(avRezArr(li, 1))
If Len(stxt) ThenIf БезПовторов Then
skey = stxt
Else
skey = oDict.Count + 1
EndIf
oDict.Item(skey) = stxt
EndIfEndIfNext li
sTmpStr = oDict.items
For li = LBound(sTmpStr) ToUBound(sTmpStr)
If Len(sStr) = 0 Then
sStr = sTmpStr(li)
Else
sStr = sStr & Разделитель & sTmpStr(li)
EndIfNext
СцепитьЕсли2 = sStr
EndFunction'---------------------------------------------------------------------------------------' Procedure : GetArr' rr - ссылка на диапазон, из значений которого надо создать массив'---------------------------------------------------------------------------------------Function GetArr(rr As Range)
Dim arr
arr = rr.Value
IfNot IsArray(arr) ThenReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rr.Value
EndIf
GetArr = arr
EndFunction'---------------------------------------------------------------------------------------' Procedure : GetArr' получаем только тот диапазон, который используется на листе' Диапазон - ссылка на диапазон'---------------------------------------------------------------------------------------Function GetIntersectRange(Диапазон As Range)
Set GetIntersectRange = Intersect(Диапазон, Диапазон.Parent.UsedRange)
EndFunction'---------------------------------------------------------------------------------------' Procedure : Get_Match' получаем только тот диапазон, который используется на листе' vCr - условие, на которое проверяем значение диапазона(vCompare)' vCompare - значение, которое проверяем на соответствие заданному критерию(vCr)'---------------------------------------------------------------------------------------Function Get_Match(ByVal vCr, ByVal vCompare) AsBooleanDim sStr AsString, sStrMatch AsStringDim objMatches AsObjectSet objMatches = objRegExp.Execute(vCr) 'Если есть вхожденияIf objMatches.Count > 0 Then
sStrMatch = objMatches.Item(0)
vCr = Replace(Replace(vCr, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
EndIfIf IsNumeric(vCr) And vCr <> ""Then
vCr = CDbl(vCr)
EndIfSelectCase sStrMatch
Case"="If vCompare = vCr Then Get_Match = TrueCase"<>"If vCompare <> vCr Then Get_Match = TrueCase">=", "=>"If vCompare >= vCr Then Get_Match = TrueCase"<=", "=<"If vCompare <= vCr Then Get_Match = TrueCase">"If vCompare > vCr Then Get_Match = TrueCase"<"If vCompare < vCr Then Get_Match = TrueCaseElseIf vCompare Like vCr Then Get_Match = TrueEndSelectEndFunction
'---------------------------------------------------------------------------------------
' Author : Щербаков Дмитрий(The_Prist)
' Профессиональная разработка приложений для MS Office любой сложности
' Проведение тренингов по MS Excel
' https://www.excel-vba.ru
' info@excel-vba.ru
' Purpose:
'---------------------------------------------------------------------------------------
Option Explicit
Option Compare Text
Dim objRegExp As Object
'---------------------------------------------------------------------------------------
' Purpose: Функция СцепитьЕсли2 объединяет строки по заданным условиям. Допускается указание до 4-х условий
' Диапазон - диапазон, в котором просматривать условия(критерии)
' Критерий - условие отбора. Ссылка на ячейку или значение.
' Может начинаться на операторы сравнения: =; <>; =>; >=; <=; =<; >; <
' Диапазон_сцепления - диапазон из одной строки или столбца, из которого брать значения для объединения в одну строку
' Разделитель - Символ или символы, который используется для объединения отобранных значений
' БезПовторов - 1 или ИСТИНА(True) - в итоговую строку будут собраны только уникальные значения
' Диапазон2,Критерий2 и т.д. - дополнительные связки Диапазон-Критерий. До 4-х
'---------------------------------------------------------------------------------------
Function СцепитьЕсли2(ByRef Диапазон As Range, ByVal Критерий, ByRef Диапазон_сцепления As Range, _
Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False, _
Optional ByRef Диапазон2 As Range, Optional ByVal Критерий2, _
Optional ByRef Диапазон3 As Range, Optional ByVal Критерий3, _
Optional ByRef Диапазон4 As Range, Optional ByVal Критерий4) As String
Dim oDict As Object
Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long
Dim avDateArr2(), avDateArr3(), avDateArr4()
Dim rr As Range
Dim bCompare As Boolean, IsR2 As Boolean, IsR3 As Boolean, IsR4 As Boolean
Dim skey$, stxt$
Dim sTmpStr
Set oDict = CreateObject("Scripting.Dictionary")
oDict.comparemode = 1
'определяем, все ли связки Диапазон-Критерий указаны
'далее проверяем только условия, для которых есть Диапазон и Критерий
IsR2 = Not IsMissing(Критерий2) And Not Диапазон2 Is Nothing
IsR3 = Not IsMissing(Критерий3) And Not Диапазон3 Is Nothing
IsR4 = Not IsMissing(Критерий4) And Not Диапазон4 Is Nothing
'определяем вхождение диапазонов в рабочий диапазон
'нужно, чтобы отсечь лишние строки/столбцы при указании полных строк и столбцов
'Диапазон 1
Set rr = GetIntersectRange(Диапазон)
If rr Is Nothing Then
Exit Function
End If
avDateArr = GetArr(rr)
'Диапазон Сцепления
Set rr = GetIntersectRange(Диапазон_сцепления)
If rr Is Nothing Then
Exit Function
End If
avRezArr = GetArr(rr)
'Диапазон 2
If IsR2 Then
Set rr = GetIntersectRange(Диапазон2)
If rr Is Nothing Then
IsR2 = False
Else
avDateArr2 = GetArr(rr)
End If
End If
'Диапазон 3
If IsR3 Then
Set rr = GetIntersectRange(Диапазон3)
If rr Is Nothing Then
IsR3 = False
Else
avDateArr3 = GetArr(rr)
End If
End If
'Диапазон 4
If IsR4 Then
Set rr = GetIntersectRange(Диапазон4)
If rr Is Nothing Then
IsR4 = False
Else
avDateArr4 = GetArr(rr)
End If
End If
'если диапазоны указаны горизонтально - разворачиваем в вертикальный массив
If Диапазон.Columns.Count > 1 And Диапазон.Rows.Count = 1 Then
avDateArr = Application.Transpose(avDateArr)
If IsR2 Then
avDateArr2 = Application.Transpose(avDateArr2)
End If
If IsR3 Then
avDateArr3 = Application.Transpose(avDateArr3)
End If
If IsR4 Then
avDateArr4 = Application.Transpose(avDateArr4)
End If
avRezArr = Application.Transpose(avRezArr)
End If
lUBnd = UBound(avDateArr, 1)
'Опрееделяем вхождение операторов сравнения в Критерий
If objRegExp Is Nothing Then
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Global = False
objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<"
End If
For li = 1 To lUBnd
bCompare = True
If Not Get_Match(Критерий, avDateArr(li, 1)) Then
bCompare = False
End If
'2 диапазон и критерий
If IsR2 And bCompare Then
If Not Get_Match(Критерий2, avDateArr2(li, 1)) Then
bCompare = False
End If
End If
'3 диапазон и критерий
If IsR3 And bCompare Then
If Not Get_Match(Критерий3, avDateArr3(li, 1)) Then
bCompare = False
End If
End If
'4 диапазон и критерий
If IsR4 And bCompare Then
If Not Get_Match(Критерий4, avDateArr4(li, 1)) Then
bCompare = False
End If
End If
If bCompare Then
stxt = Trim(avRezArr(li, 1))
If Len(stxt) Then
If БезПовторов Then
skey = stxt
Else
skey = oDict.Count + 1
End If
oDict.Item(skey) = stxt
End If
End If
Next li
sTmpStr = oDict.items
For li = LBound(sTmpStr) To UBound(sTmpStr)
If Len(sStr) = 0 Then
sStr = sTmpStr(li)
Else
sStr = sStr & Разделитель & sTmpStr(li)
End If
Next
СцепитьЕсли2 = sStr
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetArr
' rr - ссылка на диапазон, из значений которого надо создать массив
'---------------------------------------------------------------------------------------
Function GetArr(rr As Range)
Dim arr
arr = rr.Value
If Not IsArray(arr) Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rr.Value
End If
GetArr = arr
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetArr
' получаем только тот диапазон, который используется на листе
' Диапазон - ссылка на диапазон
'---------------------------------------------------------------------------------------
Function GetIntersectRange(Диапазон As Range)
Set GetIntersectRange = Intersect(Диапазон, Диапазон.Parent.UsedRange)
End Function
'---------------------------------------------------------------------------------------
' Procedure : Get_Match
' получаем только тот диапазон, который используется на листе
' vCr - условие, на которое проверяем значение диапазона(vCompare)
' vCompare - значение, которое проверяем на соответствие заданному критерию(vCr)
'---------------------------------------------------------------------------------------
Function Get_Match(ByVal vCr, ByVal vCompare) As Boolean
Dim sStr As String, sStrMatch As String
Dim objMatches As Object
Set objMatches = objRegExp.Execute(vCr) 'Если есть вхождения
If objMatches.Count > 0 Then
sStrMatch = objMatches.Item(0)
vCr = Replace(Replace(vCr, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
End If
If IsNumeric(vCr) And vCr <> "" Then
vCr = CDbl(vCr)
End If
Select Case sStrMatch
Case "="
If vCompare = vCr Then Get_Match = True
Case "<>"
If vCompare <> vCr Then Get_Match = True
Case ">=", "=>"
If vCompare >= vCr Then Get_Match = True
Case "<=", "=<"
If vCompare <= vCr Then Get_Match = True
Case ">"
If vCompare > vCr Then Get_Match = True
Case "<"
If vCompare < vCr Then Get_Match = True
Case Else
If vCompare Like vCr Then Get_Match = True
End Select
End Function
Аргументы функции точно такие же, как и в описанной выше СцепитьЕсли, но с возможностью последними аргументами добавить еще критерии и диапазоны, где их просматривать. Требования к ним точно такие же, как и к аргументам Диапазон и Критерий.
На примере таблицы сотрудников отберем не повторяющихся сотрудников планового отдела, год рождения которых позже 1978:
Синтаксис записи в ячейку листа: =СцепитьЕсли2(A2:A20;A2;B2:B20;"; ";1;C2:C20;">1970")
Как видно, все основные аргументы записаны в том же порядке, за исключением последних двух: Диапазон2(С2:С20) - диапазон для просмотра второго условия отбора. В данном случае это столбец с годом рождения. Критерий2(">1978") - т.к. нам необходимо отобрать только тех сотрудников, год рождения которых позже 1978, то для этого аргумента указываем значение ">1978".
Ваня, Вы сами свой вопрос поняли? Что значит "выводить повторы из одной ячейки"? Функция выводит значение ячеек полностью, значит и повторы внутри неё. И к тому же - что будет критерием для этой одной ячейки?
Добавил новый модуль вставил код, функция "СцепитьЕсли" появилась. Но в результате при вводе формулы появляется ошибка "Syntax error" и подсвечивает в коде "If Диапазон.Count > 1 Then". Что я не так сделал? Когда я ввожу свои данные в Ваш файл, то все работает, а в моем созданном нет.
Дмитрий добрый день! Что нужно поменять в коде чтобы СЦЕПИТЬ НЕСКОЛЬКО ЗНАЧЕНИЙ В ОДНУ ЯЧЕЙКУ ПО КРИТЕРИЮ объединения ячеек. То есть в одном столбце есть объединенные ячейки по 2 и по 3 ячейки, также есть и простые ячейки без объединения. По этому критерию нужно сцепить значения в другом столбце, соответственно 2 ячейки - напротив объединненый 2-х, 3 ячейки - напротив 3-х объединных. Ячейки напротив необЪединенных ячеек просто перенести.
Возможно ли такое?
Подскажите пожалуйста, а как сделать чтоб выводились повторы даже из одной ячейки?
Ваня, Вы сами свой вопрос поняли? Что значит "выводить повторы из одной ячейки"? Функция выводит значение ячеек полностью, значит и повторы внутри неё. И к тому же - что будет критерием для этой одной ячейки?
Добавил новый модуль вставил код, функция "СцепитьЕсли" появилась. Но в результате при вводе формулы появляется ошибка "Syntax error" и подсвечивает в коде "If Диапазон.Count > 1 Then". Что я не так сделал? Когда я ввожу свои данные в Ваш файл, то все работает, а в моем созданном нет.
Поправил код на странице(после обновления некоторые символы перекодировались и получилась такая каша).
Дополнение к выше написанному: Другие функции (коды взяты с этого сайта) добавлял в свой файл, работают. А СцепитьЕсли нехочет. Прошу помощи.
Большое спасибо, все заработало.
РАБОТАЕТ!!!
КРУТО!!!
АПЛОДИРУЮ СТОЯ!!!
Замечательный макрос. А вот как бы его подружить с MacOS?
Я так понимаю нужно как-то обойтись без VBScript.RegExp и
Scripting.Dictionary. Но вот как?
Дмитрий добрый день! Что нужно поменять в коде чтобы СЦЕПИТЬ НЕСКОЛЬКО ЗНАЧЕНИЙ В ОДНУ ЯЧЕЙКУ ПО КРИТЕРИЮ объединения ячеек. То есть в одном столбце есть объединенные ячейки по 2 и по 3 ячейки, также есть и простые ячейки без объединения. По этому критерию нужно сцепить значения в другом столбце, соответственно 2 ячейки - напротив объединненый 2-х, 3 ячейки - напротив 3-х объединных. Ячейки напротив необЪединенных ячеек просто перенести.
Возможно ли такое?
Подскажите, пожалуйста,
как в качестве разделителя использовать:
вначале нумерацию, затем значение подобранное по условию, затем точку с запятой,
Огромное человеческое спасибо за то, что Вы делаете! )))