If Not Intersect(Target, Range("Календарь")) Is Nothing Then
            Dim ILastRow As Long
            ILastRow = Cells(9, "G").End(xlDown).Row + 1
            Cells(ILastRow, "G") = Target
            Cells(ILastRow, "G").Offset(0, 1).Select
            Cancel = True
        End If

Cells(iLastRow, "G") = Target

            If Not Intersect(Target, Range("E6:G1000")) Is Nothing Then 'Кнопку в ячейку 
                    Shape30.Visible = True 'Кнопка отображена
                    Shape30.Top = ActiveCell.Offset(1, 1).Top 
                    Shape30.Left = ActiveCell.Offset(1, 1).Left
                    Shape30.DrawingObject.Caption = ActiveCell.EntireRow.Cells(5) & Chr(10) & ActiveCell.EntireRow.Cells(6)
            End If                       

ActiveCell.EntireRow.Cells(4).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True

    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

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

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

    Dim vVal 'Быстрый ввод времени в ячейку
    Dim StrVal As String
    If Not Intersect(Target, Range("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

Sub Поиск_Яч(Optional t) 'поиск по листу
Static rLastFound As Range
  If IsMissing(t) Then 'вызов по горячей клавише
    If Not rLastFound Is Nothing Then Set rLastFound = Cells.FindNext(rLastFound)
  Else
    Set rLastFound = Cells.Find(What:=t, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
              'MsgBox "Не найдено!", vbExclamation, "ВНИМАНИЕ!!!"
            'Exit Sub
  End If
  If Not rLastFound Is Nothing Then rLastFound.Offset(0, 1).Activate
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Address(0, 0) = "E1" Then
           Поиск_Яч Target 'поиск в ячейке E1
        End If
End Sub

Sub ВСЕ_КНОПКИ()
With Selection.Parent
       .DrawingObjects.Interior.Color = Sheets("Задачи").Range("AM1").Interior.Color
            Start = Timer
                Do While Timer < Start + 0.1 ' пауза в секундах
                DoEvents
            Loop
       .DrawingObjects.Interior.Color = Sheets("Задачи").Range("AJ1").Interior.Color
   End With
End Sub

Sub Открыть_Ексель_из_Оутлук()
            A = ActiveCell.Column
            ActiveCell.EntireRow.Cells(13).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True ' Открывает файл с диска по гиперссылке 
           sFolder = "C:\Users\.............\ЯВРЕМ\" 'сохранение файлов во временную папку
    With GetObject(, "Outlook.Application")
            Set oMailItm = .ActiveExplorer.Selection.Item(1)
            myAddr = oMailItm.Session.CurrentUser.Address
        For Each oAtch In oMailItm.Attachments
            If oAtch Like "*.xls*" Then
                s = GetAtchName(sFolder & ThisWorkbook.ActiveSheet.Cells(6, A) & " " & oAtch)
               oAtch.SaveAsFile s         'сохраняет в указанную папку
               Workbooks.Open Filename:=s
            End If
        Next
    End With
End Sub

        If Not Intersect(Target, Range("I7:I500")) Is Nothing Then 'Подсказка в ячейкe
            If Target.Cells.CountLarge > 1 Then Exit Sub
            If Target = "" Then Exit Sub
            ActiveSheet.Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:="", TextToDisplay:="", _
            ScreenTip:=Workbooks("Нева").Sheets("Лист1").Range("L1").Text
            Target.Font.Underline = xlUnderlineStyleNone
            Target.Font.ColorIndex = xlAutomatic
            Selection.Font.Bold = True
        End If

For Each oAtch In oMail.Attachments
oAtch.SaveAsFile ActiveCell.EntireRow.Cells(5).Value & "\" & Target.EntireColumn.Cells(4) & " " & oAtch

Target.EntireColumn.Cells(4)

Private Sub Worksheet_Change(ByVal Target As Range)
        If Not Intersect(Target, Range("G5:V1000")) Is Nothing Then
        If Target = "" Then
            ActiveCell.Interior.Color = Cells(Target.Row, 25).Interior.Color
        Else
            Target.Interior.ColorIndex = 27
        End If
        If Target = "НЕТ" Then
            Target.Interior.ColorIndex = 19
        End If
...........

  If Target = "" Then

Sub Влож_Оутлук()
            ActiveCell.EntireRow.Cells(6).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True ' Открывает мой файл по гиперссылке
            sFolder = "C:\Users\............\ВРЕМ\" 'сохранение файлов в папку
With GetObject(, "Outlook.Application")
            Set oMailItm = .ActiveExplorer.Selection.Item(1)
            myAddr = oMailItm.Session.CurrentUser.Address
        For Each oAtch In oMailItm.Attachments
            If oAtch Like "*.xls*" Then
                s = GetAtchName(sFolder & oAtch)    'путь файла к папке
               oAtch.SaveAsFile s         'сохраняет в указанную папку
               Workbooks.Open Filename:=s
            End If
        Next
End With
End Sub

s = GetAtchName(sFolder & ActiveCell.EntireColumn.Cells(4) & oAtch)    'путь файла к папке

s = GetAtchName(sFolder & Date & oAtch)    'путь файла к папке