Private WithEvents SpinBtn As MSForms.SpinButton
Private dVal#, dShift#, num As Byte
Public self As ClsSpinBtns
Public Property Set OleObj(obj As OLEObject)
    Set SpinBtn = obj.Object
    dVal = SpinBtn.Parent.Range(SpinBtn.LinkedCell).Value
    dShift = val(Replace(Replace(SpinBtn.Name, "*", "", InStr(SpinBtn.Name, "_") + 1), "_", "."))
    num = IIf(dShift \ 1 = dShift / 1, 0, Len(Trim(dShift)) - InStr(Trim(dShift), ","))
    Set self = Me
End Property
Private Sub SpinBtn_SpinUp()
    If dShift = 0 Then Exit Sub
    Application.EnableEvents = False
    With SpinBtn.Parent.Range(SpinBtn.LinkedCell)
        Dim v#: v = Round(dVal + dShift, num)
        .Value = IIf(v <= SpinBtn.Max, v, .Value)
        dVal = .Value
    End With
    Application.EnableEvents = True
End Sub
Private Sub SpinBtn_SpinDown()
    If dShift = 0 Then Exit Sub
    Application.EnableEvents = False
    With SpinBtn.Parent.Range(SpinBtn.LinkedCell)
        Dim v#: v = Round(dVal - dShift, num)
        .Value = IIf(v >= SpinBtn.Min, v, .Value)
        dVal = .Value
    End With
    Application.EnableEvents = True
End Sub

Public col As Collection
Public Sub init()
    If Not col Is Nothing Then
        For Each itm In col
            Set itm.self = Nothing
        Next
    End If
    Set col = New Collection
    Dim Sh As Worksheet, obj As OLEObject
    For Each Sh In Sheets
    For Each obj In Sh.OLEObjects
        If obj.progID = "Forms.SpinButton.1" Then
            With New ClsSpinBtns
                Set .OleObj = obj
                col.Add .self, Sh.Range(obj.LinkedCell).Address(, , , 1)
            End With
        End If
    Next obj, Sh
End Sub

Private Sub Workbook_Open()
    Call init
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim cell As Range
    On Error Resume Next
    For Each cell In Target
        If Not col(cell.Address(, , , 1)) Is Nothing Then Call init
    Next
End Sub

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