Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewCellValue$, OldComment$
Dim cell As Range
    
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("F5:F150")) Is Nothing Then Exit Sub
    
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("F5:F150"))
    
        If IsEmpty(cell) Then
            NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки
        Else
            NewCellValue = Format(cell, "dd.mm.yyyy hh:mm")     'или ее содержимое
        End If
        On Error Resume Next
        
        With cell.Offset(rowOffset:=0, columnOffset:=7)


            OldComment = .Comment.Text & Chr(10)
            .Comment.Delete     'удаляем старое примечание (если было)
            .AddComment         'добавляем новое и вводим в него текст
            .Comment.Text Text:=OldComment & Application.UserName & " " & _
                            Format(Now, "dd.mm.yyyy hh:mm") & " : " & NewCellValue
            .Comment.Shape.TextFrame.AutoSize = True    'делаем автоподбор размера
            .Comment.Shape.TextFrame.Characters.Font.Size = 8
        End With
    Next cell
    
End Sub

Private Sub CommandButton2_Click()
    Dim i As Long
    
    With ListBox1

    For i = Me.ListBox1.ListCount - 1 To 0 Step -1
        If Me.ListBox1.Selected(i) Then
           j = j + 1
            Sheets("Info_list").Range("A" & i + 2).Resize(1, 7).Copy Sheets("Лист1").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Info_list").Range("A" & i + 2).Resize(1, 7).Delete
        End If
   Next i
    
    LoadListBox
    
      MsgBox "'OK'", vbInformation
End With
End Sub

Private Sub CommandButton2_Click()
    Dim i As Long, DelData As String, k As String, k1 As Long, DelStr As String, iLastRow As Long, iLastCol As Long
  Dim delRange As Range

    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            DelStr = DelStr & ListBox1.List(i, 0) & vbCrLf
            If delRange Is Nothing Then
              Set delRange = listBoxRange.Rows(i + 1)
            Else
              Set delRange = Union(delRange, listBoxRange.Rows(i + 1))
            End If
        End If

    Next i

delRange.EntireRow.Delete
UserForm_Initialize
    MsgBox "Запрос успешно обработан - " & vbLf & DelStr, vbInformation

End Sub

Sub SendEmail()
  'Uses late binding
  Dim OutlookApp As Object
  Dim MItem As Object
  Dim cell As Range
  Dim Subj As String
  Dim EmailAddr As String
  Dim Recipient As String
  Dim Bonus As String
  Dim Msg As String
  
  'Create Outlook object
  Set OutlookApp = CreateObject("Outlook.Application")
  
  
  'Loop through the rows
  For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "*@*" Then
      'Get the data
      Subj = "Your Annual Bonus"
      Recipient = cell.Offset(0, -1).Value
      EmailAddr = cell.Value
      Bonus = Format(cell.Offset(0, 1).Value, "$0,000.")
            
     'Compose message
      Msg = "Dear " & Recipient & vbCrLf & vbCrLf
      Msg = Msg & "I am pleased to inform you that your annual bonus is "
      Msg = Msg & Bonus & vbCrLf & vbCrLf
      Msg = Msg & "William Rose" & vbCrLf
      Msg = Msg & "President"
    
      'Create Mail Item and send it
      Set MItem = OutlookApp.CreateItem(0) 'olMailItem
      With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        '.Send
        .Save 'to Drafts folder
      End With
    End If
  Next
  Set OutlookApp = Nothing
End Sub

Option Explicit
 
Sub Send_Mail()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = CreateObject("Outlook.Application")
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "AddressTo@mail.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Автоотправка"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Привет от Excel-VBA"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:/Temp/Книга1.xls"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
    
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        .Attachments.Add sAttachment
        .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
exit_:
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton16_Click()    Dim wb As Workbook
Application.Dialogs(xlDialogInsertHyperlink).Show