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

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

Option Explicit
Public WithEvents img As MSForms.Image
Public self As ClsImg

Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (ByRef lpPictDesc As PicBmp, riid As GUID, ByVal fOwn As Long, ByRef lplpvObj As Any) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function CopyImage Lib "user32.dll" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
Private Type PicBmp
  Size As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Private Sub Class_Initialize()
    Set self = Me
End Sub

Private Sub img_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    PastePictureFromClipboard img
End Sub

Private Function GetPicture(ByVal hPic As Long, ByVal PicType As Long) As IPictureDisp
    Dim p As PicBmp, g As GUID
    With p
        .hBmp = hPic
        .Size = Len(p)
        .Type = PicType
    End With
    With g
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(3) = &HAA
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
  OleCreatePictureIndirect p, g, 1, GetPicture
End Function

Private Sub PastePictureFromClipboard(ByRef img As Image)
    OpenClipboard 0
    If IsClipboardFormatAvailable(2) Then
        Set img.Picture = GetPicture(CopyImage(GetClipboardData(2), 0, 0, 0, 0), 1)
    End If
    CloseClipboard
End Sub

Public Sub init()
    Dim sh As Worksheet, obj As OLEObject, itm As ClsImg
    If Not col Is Nothing Then
        For Each itm In col
            Set itm.self = Nothing
        Next
    End If
    Set col = New Collection
    For Each sh In Sheets
    For Each obj In sh.OLEObjects
        If TypeOf obj.Object Is MSForms.Image Then
            Set itm = New ClsImg
            Set itm.img = obj.Object
            col.Add itm
        End If
    Next obj, sh
End Sub