Как сцепить несколько значений в одну ячейку по критерию? СцепитьЕсли

Камиль:

Добрый день.

Скажите, пожалуйста, вот на версии х86 (32) работает нормально.
А на версии офис х64, выдает ошибку #знач / # value.
Может что-то нужно изменить в коде?

Даниил:

unction СЦЕПИТЬЕСЛИ(ByRef Диапазон As Range, ByVal Критерий As String, ByVal Критерий2 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 = "=||=>|>=|<=|=| 0 Then
Dim sStrMatch As String
sStrMatch = objMatches.Item(0)
Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
Критерий2 = Replace(Replace(Критерий2, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
If IsNumeric(Критерий) And Критерий "" Then
Критерий = CDbl(Критерий)
If IsNumeric(Критерий2) And Критерий2 "" Then
Критерий2 = CDbl(Критерий2)
End If
Select Case sStrMatch
Case "="
For li = 1 To lUBnd
If avDateArr(li, 1) = Критерий And avDateArr(li, 1) = Критерий2 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) Критерий And avDateArr(li, 1) Критерий2 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) >= Критерий And avDateArr(li, 1) >= Критерий2 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) <= Критерий And avDateArr(li, 1) <= Критерий2 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) > Критерий And avDateArr(li, 1) > Критерий2 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) < Критерий And avDateArr(li, 1) < Критерий2 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 Критерий And avDateArr(li, 1) Like Критерий2 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
Написал формулу для сцепления с 2мя условиями( по вашей рекомендации) не могли бы подпраить, что я сделал не так

Евгений:

А как из Вашего примера можно получить перечень сотрудников, у которых оклад находится в диапазоне от 50000 до 10000 ?