Option Explicit
Const Sep$ = "; " ' разделитель при перечислении значений ячеек
Const MaxCells% = 16 ' максимальное количество значений ячеек при их перечислении
Dim sOldValue As String
Dim sOldarr1()

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Application.EnableEvents = True
   '---------------------------------------------------------------------------------------
   ' Procedure : Workbook_SheetChange
   ' Author    : The_Prist (идея) & Alex_St (доработка)
   ' URL       : http://www.excel-vba.ru/index.php?file=Tips_Macro_Log
   ' Date      :
   ' Purpose   : Ведение ЛОГ-файла произведенных изменений на листе LOG
   ' Notes     :
   '---------------------------------------------------------------------------------------
   If Sh.Name = "LOG" Then Exit Sub
   Dim sNewValue As String
   Dim lLastRow As Long
   Dim rCell As Range
    'MsgBox "Тут"
    Dim cur_line As Integer
   Dim vag_col As Integer
   vag_col = 2
   
   With Sheets("LOG")
      
      'incriser = lLastRow + 1
      If Not Intersect(Target, Sh.UsedRange) Is Nothing Then
         If Target.Count > 1 Then
            cur_line = 1
            
            For Each rCell In Intersect(Target, Sh.UsedRange)
             lLastRow = .UsedRange.Row + .UsedRange.Rows.Count
      If lLastRow = .Rows.Count Then Exit Sub
                MsgBox "change"
                Application.ScreenUpdating = False: Application.EnableEvents = False
                .Cells(lLastRow, 1) = CreateObject("wscript.network").UserName
                .Cells(lLastRow, 2) = Format(Now, "dd.mm.yyyy HH:MM:SS")
                .Cells(lLastRow, 3) = Sh.Name
                .Cells(lLastRow, 4) = Target.Address(0, 0)
                .Cells(lLastRow, 5) = sOldarr1(cur_line)
                .Cells(lLastRow, 6) = rCell
                .Cells(lLastRow, 7) = Cells(rCell.Row, vag_col)
               'If Not IsError(Target) Then sNewValue = sNewValue & Sep & rCell Else sNewValue = sNewValue & Sep & "Err"
               'If UBound(Split(sNewValue, Sep)) > MaxCells - 1 Then sNewValue = sNewValue & Sep & "...": Exit For
                 cur_line = cur_line + 1
            Next rCell
            'sNewValue = Mid(sNewValue, Len(Sep) + 1)
         Else
                lLastRow = .UsedRange.Row + .UsedRange.Rows.Count
                If lLastRow = .Rows.Count Then Exit Sub
                Application.ScreenUpdating = False: Application.EnableEvents = False
                .Cells(lLastRow, 1) = CreateObject("wscript.network").UserName
                .Cells(lLastRow, 2) = Format(Now, "dd.mm.yyyy HH:MM:SS")
                .Cells(lLastRow, 3) = Sh.Name
                .Cells(lLastRow, 4) = Target.Address(0, 0)
                .Cells(lLastRow, 5) = sOldValue
                .Cells(lLastRow, 6) = Target.Value
                .Cells(lLastRow, 7) = Cells(Target.Row, vag_col)
                'MsgBox Target.Value
            If Not IsError(Target) Then sNewValue = Target.Value Else sNewValue = "Err"
         End If
      End If
     ' .Cells(lLastRow, 6) = sNewValue
   End With
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   Dim rCell As Range, i%
   'Dim sOldValue()
   Dim cur_line As Integer
   'MsgBox Target.Count
   
   'sOldValue = ""
   If Sh.Name = "LOG" Then Exit Sub
   cur_line = 1
   If Not Intersect(Target, Sh.UsedRange) Is Nothing Then
      cur_line = 1
      MsgBox Target.Count
      If Target.Count > 1 Then
                ReDim sOldarr1(1 To Target.Count)
         For Each rCell In Intersect(Target, Sh.UsedRange)
                sOldarr1(cur_line) = rCell
                cur_line = cur_line + 1
         Next rCell
         'sOldValue = Mid(sOldValue, Len(Sep) + 1)
      Else
         If Not IsError(Target) Then sOldValue = Target.Value Else sOldValue = "Err"
      End If
   End If
End Sub