If Not Intersect(Target, Range("Учет.Тип")) Is Nothing Then
     If IsEmpty(Target) Then Exit Sub
     If WorksheetFunction.CountIf(Sheets("Справочник").Range("Справочник.Тип"), Target) = 0 Then
      lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список - Справочник. Тип?", vbYesNo + vbQuestion)
      If lReply = vbYes Then
          Sheets("Справочник").Range("Справочник.Тип").Cells(Sheets("Справочник").Range("Справочник.Тип").Rows.Count + 1, 1) = Target
      End If
     End If
    End If

 Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim lReply As Long
 
   If Target.Cells.Count > 1 Then Exit Sub
     If Not Intersect(Target, Range("Учет.Тип")) Is Nothing Then
      If IsEmpty(Target) Then Exit Sub
          If WorksheetFunction.CountIf(Sheets("Справочник.Тип").Range("Справочник.Тип"), Target) = 0 Then
           lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список - Справочник. Тип?", vbYesNo + vbQuestion)
            If lReply = vbYes Then
                Sheets("Справочник.Тип").Range("Справочник.Тип").Cells(Sheets("Справочник.Тип").Range("Справочник.Тип").Rows.Count + 1, 1) = Target
            End If
          End If
      Else
      If Not Intersect(Target, Range("Учет.Бренд")) Is Nothing Then
      If IsEmpty(Target) Then Exit Sub
          If WorksheetFunction.CountIf(Sheets("Справочник.Бренд").Range("Справочник.Бренд"), Target) = 0 Then
           lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список - Справочник. Бренд?", vbYesNo + vbQuestion)
            If lReply = vbYes Then
                Sheets("Справочник.Бренд").Range("Справочник.Бренд").Cells(Sheets("Справочник.Бренд").Range("Справочник.Бренд").Rows.Count + 1, 1) = Target
             End If
          End If
      Else
      If Not Intersect(Target, Range("Учет.Модель")) Is Nothing Then
      If IsEmpty(Target) Then Exit Sub
          If WorksheetFunction.CountIf(Sheets("Справочник.Модель").Range("Справочник.Модель"), Target) = 0 Then
           lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список - Справочник. Модель?", vbYesNo + vbQuestion)
            If lReply = vbYes Then
                Sheets("Справочник.Модель").Range("Справочник.Модель").Cells(Sheets("Справочник.Модель").Range("Справочник.Модель").Rows.Count + 1, 1) = Target
            End If
          End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)     
Application.DisplayAlerts = False    For Each cell In Target   ' 
 If Not Intersect(Cell, Union([C11], [C62:C65])) Is Nothing Then ' C11, C62:C65       
Cell.Offset(0, 3) = Now     
End If     
Next cell     
Application.DisplayAlerts = True 
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Application.DisplayAlerts = False For Each cell In Target    If Not Intersect(cell, [C11], [C62:C65]) Is Nothing Then '    End If    Next cell    Application.DisplayAlerts = TrueEnd Sub

   Private Sub Worksheet_Change(ByVal Target As Range)    Application.DisplayAlerts = False    For Each cell In Target   If Not Intersect(cell, [C11], [C62:C65]) Is Nothing Then '      Cell.Offset(0, 3) = Now    End If    Next cell    Application.DisplayAlerts = TrueEnd Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.DisplayAlerts = False
    For Each cell In Target   'проходим по всем измененным ячейкам
    If Not Intersect(cell, Range("C11, C62:C65"    ) Is Nothing Then 'если изменененная ячейка попадает в диапазон C11, C62:C65
      
    End If
    Next cell
    Application.DisplayAlerts = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) 
 Application.DisplayAlerts = False 
 For Each cell In Target 
    If Not Intersect(cell, Range("C11, C61:C64" [IMG WIDTH=16 HEIGHT=16]http://www.planetaexcel.ru/bitrix/images/forum/smile/icon_wink.gif[/IMG] ) Is Nothing Then 
      With cell.Offset(0, 3)    
      [COLOR=#ff0000] .Value = Now [/COLOR]
       End With 
    End If 
 Next cell 
 Application.DisplayAlerts = True 
End Sub

  With OutMail      
.To = Range("G7" [IMG] .Value      
.Subject = Range("A5" [IMG] .Value      
.Body = "Добрый день. Прошу рассмотреть запрос на скидку. Паспорт сделки во вложении."      'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой   
.Display     End With 

Sub SendMail()
    ActiveWorkbook.SendMail
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range     
     
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application" ;)    'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon
    On Error GoTo cleanup  'если не запустился - выходим
    Set OutMail = OutApp.CreateItem(0)  'создаем новое сообщение
    On Error Resume Next
    'заполняем поля сообщения
    With OutMail
     .To = Range("G7" ;) .Value
     .Subject = Range("A5" ;) .Value
     .Body = "Добрый день. Прошу рассмотреть запрос на скидку. Паспорт сделки во вложении."
     'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой
     .Display 
    End With
 
    On Error GoTo 0
    Set OutMail = Nothing
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub