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("E5:E10000")) 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
                        Worksheets("Контрагент").Range("Контрагент").Cells(Worksheets("Контрагент").Range("Контрагент").Rows.Count + 1, 1) = Target
                        Sheets("Контрагент").Range("B1:B1000").Sort Key1:=Sheets("Контрагент").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If
    
    If Not Intersect(Target, Range("G5:G10000")) 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
                        Worksheets("Продукция").Range("Продукция").Cells(Worksheets("Продукция").Range("Продукция").Rows.Count + 1, 1) = Target
                        Sheets("Продукция").Range("B1:B1000").Sort Key1:=Sheets("Продукция").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If
    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) 'макрос отслживания изменений
Dim NewCellValue$, OldComment$
Dim cell As Range
     
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("A5:S10000")) Is Nothing Then Exit Sub
     
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("A5:S10000"))
        If IsEmpty(cell) Then
            NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки
        Else
            NewCellValue = cell.Formula     'или ее содержимое
        End If
        On Error Resume Next
         
        With cell
            OldComment = .Comment.Text & Chr(10)
            .Comment.Delete     'удаляем старое примечание (если было)
            .AddComment         'добавляем новое и вводим в него текст
            .Comment.Text Text:=OldComment & Application.UserName & " " & _
                            Format(Now, "MM.DD.YY h:MM:ss") & " : " & NewCellValue
            .Comment.Shape.TextFrame.AutoSize = True    'делаем автоподбор размера
            .Comment.Shape.TextFrame.Characters.Font.Size = 8
        End With
    Next cell
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)