Private Sub Worksheet_Change(ByVal Target As Range)   
   If Not Intersect(Target, Range("A1")) Is Nothing Then   
      If Target = 1 Then   
         MsgBox "Здесь вызываем Ваш макрос"   
      End If   
   End If   
End Sub

'.UsedRange.Offset(1, 0).ClearContents

Private Sub OkBtn_Click()
    Dim arr(2), lrow&, i&, j&, x&
    x = 0
    With Лист1
        lrow = .Range("b" & .Rows.Count).End(xlUp).Row
        For i = 0 To 2
            arr(i) = .Range(.[a3], .Range("aa" & lrow)).Value
        Next i
    End With
    With CreateObject("Scripting.Dictionary")
        For i = 0 To Me.iListDate.ListCount - 1
            If Me.iListDate.Selected(i) Then .Item(CStr(CStr(Me.iListDate.List(i)))) = 0
        Next i
        If .Count = 0 Then Exit Sub
        For i = 1 To UBound(arr(0))
            If .exists(CStr(arr(0)(i, 4))) Then
                x = x + 1
                arr(1)(x, 1) = x: arr(1)(x, 2) = arr(0)(i, 3)
                arr(1)(x, 3) = arr(0)(i, 2): arr(1)(x, 4) = arr(0)(i, 6)
                arr(1)(x, 5) = arr(0)(i, 8: arr(1)(x, 6) = arr(0)(i, 4)
                arr(1)(x, 7) = arr(0)(i, 5): arr(1)(x, 8 = arr(0)(i, 25)
            End If
        Next i
    End With
    With Лист2
        .UsedRange.Offset(1, 0).ClearContents
        .Columns(2).NumberFormat = "@"
        .Range("a2").Resize(x, 8 = arr(1)
    End With    Unload Me
End SubPrivate Sub UserForm_Initialize()
    Dim arr(), lrow&
    With Лист1
        lrow = .Range("x" & .Rows.Count).End(xlUp).Row
        arr = .Range(.[x3], .Range("x" & lrow)).Value
    End With
    With CreateObject("Scripting.Dictionary")
        For lrow = 1 To UBound(arr)
            .Item(CStr(arr(lrow, 1))) = 0
        Next lrow
        Me.iListDate.List = .keys
    End With
End Sub