Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     If Not Intersect(Target, Range("K1:K1000")) Is Nothing Then 'делаем так, чтобы он работал только в диапазоне ячеек K1-K1000
     With Target(1, 1) 'указываем, с какой ячейкой работать в данный момент
     .Value = .Value & vbLf & Now & " " & Application.UserName & ": " 'добавляем к активированной ячейке её же данные + перенос на новую строку + точное время\дату + пробел + имя пользователя + двоеточие и пробел (т.е. получается нечто вроде "16.10.2014 16:56:54 А. Иванов: ")
     End With
     Cancel = True
     End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
      If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'делаем так, чтобы он работал только в диапазоне ячеек K1-K1000
          With Target(1, 1) 'указываем, с какой ячейкой работать в данный момент
              If IsEmpty(Target) Then
              .Value = Now & " " & Application.UserName & ": " 'добавляем к активированной ячейке её же данные + перенос на новую строку + точное время\дату + пробел + имя пользователя + двоеточие и пробел (т.е. получается нечто вроде "16.10.2014 16:56:54 А. Иванов: ")
              Else
              .Value = .Value & vbLf & Now & " " & Application.UserName & ": " 'добавляем к активированной ячейке её же данные + перенос на новую строку + точное время\дату + пробел + имя пользователя + двоеточие и пробел (т.е. получается нечто вроде "16.10.2014 16:56:54 А. Иванов: ")
              End If
          End With
      Cancel = True
      End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику
     If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек
         With Target(1, 1) 'указываем, с какой ячейкой работать макросу
             If IsEmpty(Target) Then 'если ячейка изначально пуста, то включаем макрос без перевода на новую строку
             .Value = Now & " " & Application.UserName & ": "
             Else 'в противном случае - перевод на новую строку будет
             .Value = .Value & vbLf & Now & " " & Application.UserName & ": "
             End If
         End With
     End If
Cancel = 0
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику
        If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек
            With Target(1, 1) 'указываем, с какой ячейкой работать макросу
                If IsEmpty(Target) Then 'если ячейка изначально пуста, то включаем макрос без перевода на новую строку
                .Value = Now & " " & Application.UserName & ": "
                Else 'в противном случае - перевод на новую строку будет
                .Value = .Value & vbLf & Now & " " & Application.UserName & ": "
                End If
                    
                If Application.UserName = "Иванов А." Then
                Target.Font.Color = vbRed
                Else
                Target.Font.Color = vbBlue
                End If
                    
            End With
        End If
Cancel = 0
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику
     If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек
             With Target(1, 1) 'указываем, с какой ячейкой работать макросу
                 Dim Name$: Name = Application.UserName
                 If IsEmpty(Target) Then 'если ячейка изначально пуста, то включаем макрос без перевода на новую строку
                     .Value = Now & " " & Name & ": "
                 Else
                     .Value = .Value & vbLf & Now & " " & Name & ": "
                 End If
                 'With .Characters(InStr(.Value, Name), Len(Name)) ' если раскомментировать эту строку и закометировать следующую, то выделится только имя пользователя
                 With .Characters(Len(.Value), 1)
                     .Font.Color = IIf(Name = "Иванов А.", vbRed, vbBlue)
                 End With
                 Application.SendKeys "^{END}"
             End With
         End If
Cancel = 0
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику
    On Error GoTo err
     If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек
         With Target(1, 1) 'указываем, с какой ячейкой работать макросу
             With Application: .ScreenUpdating = 0: .EnableEvents = 0: End With
             Dim Name$: Name = Application.UserName
             Dim L&: L = Len(.Value)
             Dim char, arr&(), i&
             ReDim arr(L + (L > 0))
             For i = 1 To L: arr(i - 1) = .Characters(i, 1).Font.Color: Next
             'если ячейка изначально пуста, то включаем макрос без перевода на новую строку
             .Value = .Value & IIf(L, vbLf, "") & Now & " " & Name & ": "
             For i = 1 To L: .Characters(i, 1).Font.Color = arr(i - 1): Next
             'With .Characters(InStr(.Value, Name), Len(Name)) ' если раскомментировать эту строку и закометировать следующую, то выделится только имя пользователя
             With .Characters(L + 1, Len(.Value) - L - 1)
                 .Font.Color = IIf(Name = "krosav4ig", vbRed, vbBlue)
             End With
             .Characters(Len(.Value)).Font.ColorIndex = xlAutomatic
             Application.SendKeys "^{END}"
         End With
     End If
     Cancel = 0
     If err.Number Then MsgBox "Ошибка " & err.Number & " (" & err.Description & ") в Worksheet_BeforeDoubleClick модуля Лист2"
err:
With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику
         If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек
             With Target(1, 1) 'указываем, с какой ячейкой работать макросу
                 With Application: .ScreenUpdating = 0: .EnableEvents = 0: End With 'оптимизация производительности макроса
                 Dim Name$: Name = Application.UserName 'задаём переменную Name, содержащую имя пользователя
                 'волшебство начинается
                 Dim L&: L = Len(.Value)
                 Dim char, arr&(), i&
                 ReDim arr(L + (L > 0))
                 For i = 1 To L: arr(i - 1) = .Characters(i, 1).Font.Color: Next
                 'волшебство заканчивается
                 .Value = .Value & IIf(L, vbLf, "") & Now & " " & Name & ": " 'проставляем дату\время\ФИО, в скобках - условие "пустая ли ячейка?" (т.е. делать перенос строки или нет)
                 For i = 1 To L: .Characters(i, 1).Font.Color = arr(i - 1): Next 'ещё немного волшебства
                     With .Characters(L + 1, Len(.Value) - L - 1)
                     .Font.Color = IIf(Name = "Иванов А." Or Name = "Андреев П." Or Name = "Васьков А.", vbBlue, vbBlack) 'выделяем дату\время\ФИО в комментарии определённого пользователя
                     End With
                 .Characters(Len(.Value)).Font.ColorIndex = xlAutomatic 'оптимизация производительности макроса
             End With
         End If
Cancel = 0 'открываем ячейку по двойному клику, а не только добавляем в неё данные
With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With 'оптимизация производительности макроса
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику
Cancel = 1
         On Error GoTo err 'если произойдет какая-нибудь ошибка, выполнить последнюю строку кода
         If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек
             With Target(1, 1) 'указываем, с какой ячейкой работать макросу
                 With Application: .ScreenUpdating = 0: End With 'оптимизация производительности макроса
                 Dim Name$: Name = Application.UserName 'задаём переменную Name, содержащую имя пользователя
                 'волшебство начинается
                 Dim L&: L = Len(.Value)
                 Dim D$, i&, tmp$, k$
                 Select Case Application.MoveAfterReturnDirection
                     Case xlDown: D = "UP": Case xlUp: D = "DOWN"
                     Case xlRight: D = "LEFT": Case xlLeft: D = "RIGHT"
                 End Select
                 k = "{F2}^{END}" & IIf(L, "%{ENTER}", "") & Now & " " & Name & ": {ENTER}{" & D & "}"
                 Application.SendKeys k
                 DoEvents
                 'волшебство закончилось ; )
                 With .Characters(L + 1, Len(.Value) - L - 1)
                     .Font.Color = IIf(Name = "Иванов А." Or Name = "Андреев П." Or Name = "Васьков А.", vbBlue, vbBlack) 'выделяем дату\время\ФИО в комментарии определённого пользователя
                 End With
                 With .Characters(L + 1, Len(.Value) - L).Font
                     .Name = Application.StandardFont: .Bold = 0: .Italic = 0
                     .Size = Application.StandardFontSize: .Strikethrough = 0
                     .Subscript = 0: .Superscript = 0: .ThemeFont = xlThemeFontNone
                     .TintAndShade = 0: .Underline = xlUnderlineStyleNone
                     .OutlineFont = 0: .Shadow = 0: .FontStyle = "обычный"
                 End With
                 .Characters(L).Font.ColorIndex = xlAutomatic
             End With
             Application.SendKeys "{F2}"
         End If
err: 'следующая строка дожна быть обязательно выполнена
         With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With 'оптимизация производительности макроса
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику
Cancel = 0
       On Error GoTo err 'если произойдет какая-нибудь ошибка, выполнить последнюю строку кода
       If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек
           With Target(1, 1) 'указываем, с какой ячейкой работать макросу
           With Application: .ScreenUpdating = 0: End With 'оптимизация производительности макроса
               Dim Name$: Name = Application.UserName 'задаём переменную Name, содержащую имя пользователя
               'волшебство начинается
               Dim L&: L = Len(.Value)
               .Characters(L).Insert Right(.Value, 1) & IIf(L, vbLf, "") & Now & " " & Name & ": "
               Dim L2&: L2 = Len(Target.Characters.Text)
               Dim AL: Set AL = CreateObject("System.Collections.ArrayList")
               AL.Add "Иванов А.": AL.Add "Андреев П.": AL.Add "Васьков А."
               .Characters(L + 1, L2 - L - 1).Font.Color = IIf(AL.contains(Name), vbBlue, vbBlack) 'выделяем дату\время\ФИО в комментарии определённого пользователя
               Set AL = Nothing
               'волшебство закончилось ; )
               With .Characters(L + 1, L2 - L).Font
                   .Name = Application.StandardFont: .Bold = 0: .Italic = 0
                   .Size = Application.StandardFontSize: .Strikethrough = 0
                   .Subscript = 0: .Superscript = 0: .ThemeFont = 0
                   .TintAndShade = 0: .Underline = -4142
                   .OutlineFont = 0: .Shadow = 0: .FontStyle = "обычный"
               End With
               .Characters(L2).Font.ColorIndex = xlAutomatic
           End With
       End If
err: 'следующая строка дожна быть обязательно выполнена
       With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With 'оптимизация производительности макроса
End Sub

Dim Name$: Name = Application.UserName 'задаём переменную Name, содержащую имя пользователя
              'волшебство начинается
              Dim L&: L = Len(.Value)
              .Characters(L).Insert Right(.Value, 1) & IIf(L, vbLf, "") & Now & " " & Name & ": "