If Not Intersect(Target, Range("Числа")) Is Nothing Then 
        iLastRow = Cells(Rows.Count, "N").End(xlUp).Row + 1
        Cells(iLastRow, "N") = Target
        Cells(iLastRow, "N").Offset(0, 4).Select
        Cancel = True
    End If

Sub MailRangeJob(rr As Range)
    Dim oOutlook As Object 'Outlook.Application
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    Dim MailItem1 As Object 'MailItem
    Set MailItem1 = oOutlook.ActiveExplorer.Selection.Item(1)
    Dim sMail As String
    sMail = MailItem1.SenderEmailAddress
    On Error GoTo 0
    If sMail <> "" Then
        Dim cl As Range
        For Each cl In rr.Cells
            If InStr(sMail, cl.Value) > 0 Then
                cl.Interior.Color = Range("Q1").Interior.Color 'RGB(200, 200, 200)
            Else
            End If
        Next
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    
        If Not Intersect(Target, Range("F1")) Is Nothing Then 'Примечания в примечания
            'ThisWorkbook.Sheets("Лист1").Application.Speech.Speak "с" '[O1]
            With ActiveSheet.[F1]
            .Interior.Color = Sheets("Лист2").[A1].Interior.Color
                Start = Timer
                Do While Timer < Start + 0.3 ' пауза в секундах
                    DoEvents
                Loop
            .Interior.Color = Sheets("Лист2").[E1].Interior.Color
            End With
        End If
        
End Sub

Option Explicit

Start = Timer

Target.EntireRow.Cut
out_rng.Insert

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, [A7:A1000]) Is Nothing Then
         If Target.Cells.CountLarge > 1 Then Exit Sub
        With Target.Offset(0, 0)
            Cancel = True
            Set trgt_rng = Range([A7], [A7].End(xlDown))
            If Target.Count = 1 Then
                    Set out_rng = [A1].Offset(Cells.Rows.Count - 1).End(xlUp).Offset(1)
                    Target.EntireRow.Copy out_rng
                    Target.EntireRow.Delete
                    Application.CutCopyMode = False
                    Exit Sub
            End If
        End With
        Cancel = True
    End If
End Sub

Private WithEvents CB As CommandBars, InitFlg As Boolean
Private AW As Window, mvShape As shape, shWdh!, shHgt!


Option Explicit

Private Sub varInit()     'инициализация переменных
    Set CB = CommandBars
    Set AW = ActiveWindow
    Set mvShape = Shapes("Подсказка_Дислок")
    shWdh = mvShape.Width
    shHgt = mvShape.Height
    InitFlg = True
End Sub

Private Sub CB_OnUpdate() 'событие скроллинга
    Dim mTop!
    mTop = AW.VisibleRange.Rows(1).Top
    If mTop <> mvShape.Top Then
        With mvShape
          .Top = mTop
          .Width = shWdh
          .Height = shHgt
        End With
    End If
End Sub

    With Workbooks("Рабочий файл ").Sheets("Дислокация").Shapes.Range(Array("Подсказка_Дислок")) 'Подсказка кнопка к ячейке
    If Not Application.Intersect(Range("I7:I1000"), Target) Is Nothing Then
        If Target.Cells.CountLarge > 1 Then Exit Sub
        If Target.Offset(0, -1) = "ПРЕД" Or Target = "" Or ActiveSheet.AutoFilterMode = True Then
            Workbooks("Рабочий файл НОВЫЙ").Sheets("Дислокация").Shapes.Range(Array("Подсказка_Дислок")).Visible = False
            Exit Sub
        End If
        
        Dim wbName$, wbPath$, p&, link$
        p = InStrRev(Target.Offset(0, 10), "\")
        wbName = Mid(Target.Offset(0, 10), p + 1)
        wbPath = Left(Target.Offset(0, 10), p)
        link = "='" & wbPath & "[" & wbName & "]Лист1'!Q1"
        link1 = "='" & wbPath & "[" & wbName & "]Лист1'!R1"
        link2 = "='" & wbPath & "[" & wbName & "]Лист1'!S1"
        link3 = "='" & wbPath & "[" & wbName & "]Лист1'!T1"
        link4 = "='" & wbPath & "[" & wbName & "]Лист1'!U1"
        link5 = "='" & wbPath & "[" & wbName & "]Лист1'!V1"
        link6 = "='" & wbPath & "[" & wbName & "]Лист1'!W1"
        link7 = "='" & wbPath & "[" & wbName & "]Лист1'!F1" 'Примечания
        With Target.Offset(, 11) 'за гарницами видимого листа
          .Formula = link
        End With
        With Target.Offset(, 12) 
          .Formula = link1
        End With
        With Target.Offset(, 13) 
          .Formula = link2
        End With
        With Target.Offset(, 14) 
          .Formula = link3
        End With
        With Target.Offset(, 15) 
          .Formula = link4
        End With
        With Target.Offset(, 16) 
          .Formula = link5
        End With
        With Target.Offset(, 25) 
          .Formula = link6
        End With
        With Target.Offset(, 26) 
          .Formula = link7
        End With
               
            .Top = Target.Offset(1, -8).Top
            .Left = Target.Offset(1, -8).Left
            .Visible = True
       
            .TextFrame2.TextRange.Characters.Text = Target.EntireRow.Cells(20) & Chr(10) & Target.EntireRow.Cells(21) _
              & Chr(10) & Target.EntireRow.Cells(22) & Chr(10) & _
              Target.EntireRow.Cells(23) & Chr(10) & Target.EntireRow.Cells(24) & Chr(10) & Target.EntireRow.Cells(34) _
              & Chr(10) & Target.EntireRow.Cells(25) & ":" & Chr(10) & Target.EntireRow.Cells(35)
            .Visible = True 
        Else
            .Visible = False
    End If
    End With

    Dim WorkRange As Range, CrossRange As Range ' выделение ячеек строки
    Set WorkRange = Range("I7:S1000,Z7:AG1000")  'адрес рабочего диапазона с таблицей
        'If Target.Count > 1 Then Exit Sub
            If Coord_Selection = False Then
        WorkRange.FormatConditions.Delete
        Exit Sub
            End If
    If Not Intersect(Target, WorkRange) Is Nothing Then
        Set CrossRange = Intersect(WorkRange, Target.EntireRow)
        WorkRange.FormatConditions.Delete
        CrossRange.FormatConditions.Add Type:=xlExpression, Formula1:="=1"
        CrossRange.FormatConditions(1).Interior.Color = Range("AL1").Interior.Color             'Index = 36
        'Target.FormatConditions.Delete
    End If
    

WithEvents CB As CommandBars

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000,E5:E10000,G5:G10000")) Is Nothing Then
        If Len(Target) = 5 Or Len(Target) = 6 Then
            If IsDate(Format(Target.Value, "00\/00\/00")) Then
                If Mid(Format(Target.Value, "00\/00\/00"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/00"))
                Application.EnableEvents = True
                Else: GoTo error_
            End If
        ElseIf Len(Target) = 7 Or Len(Target) = 8 Then
            If IsDate(Format(Target.Value, "00\/00\/0000")) Then
                If Mid(Format(Target.Value, "00\/00\/0000"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/0000"))
                Application.EnableEvents = True
                Else: GoTo error_
            End If
                Else: GoTo error_
        End If
        ElseIf Not Intersect(Target, Range("D5:D10000,F5:F10000,H5:H10000")) Is Nothing Then
            If Len(Target) = 3 Or Len(Target) = 4 Then
                If IsDate(Format(Format(Target.Value, "00:00"), "h:nn")) Then
                    Application.EnableEvents = False
                    Target = Format(Format(Target.Value, "00:00"), "h:nn")
                    Application.EnableEvents = True
                Else
                    Application.EnableEvents = False
                    Application.Undo
                    Application.EnableEvents = True
                End If
            End If
        End If
        Application.EnableEvents = True
        Exit Sub
error_:
        Application.EnableEvents = False
        Target = Empty ' Punto Switcher, гад, отмене мешает
'        Application.Undo
        Application.EnableEvents = True
    End Sub

    Dim vVal 'Быстрый ввод времени в ячейку
    Dim StrVal As String
    If Not Intersect(Target, Range("A2:A5")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "hh:mm" '"[h]:mm"
            End If
        End With
     End If
     Application.EnableEvents = True