Автоматическая вставка текущей даты в ячейку при вводе данных

Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell In Target   'ïðîõîäèì ïî âñåì èçìåíåííûì ÿ÷åéêàì
       If Not Intersect(cell, Range("c2:c100")) Is Nothing Then  'åñëè èçìåíåíåííàÿ ÿ÷åéêà ïîïàäàåò â äèàïàçîí A2:A100
            With cell.Offset(0, -1)        'ââîäèì â ñîñåäíþþ ñïðàâà ÿ÷åéêó äàòó
               If IsEmpty(Target) Then
     Target(0, -1) = Empty
Else
     With Target(0, -1)
        .Value = Now
        .EntireColumn.AutoFit
     End With
End If
       End If
    Next cell
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A3:A1000")) Is Nothing Then 'если изменененная ячейка попадает в диапазон A2:A1000
        If IsEmpty(Target) Then 'проверяем на удаление информации
            Target(1, 3) = Empty 'усли пусто - тогда очистить дату
            Else ' иначе
                With Target(1, 3) 'в ячейку с указанным смещением
                .Value = Date 'ввести дату
                .EntireColumn.AutoFit
                End With
            End If
       End If
    Next cell 'к следующей ячейке
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)   
    For Each cell in Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A2:N1000")) Is Nothing Then  
            With Range("O" & cell.row)
               .Value = Now
               .EntireColumn.AutoFit  
            End With
       End If
    Next cell
End Sub

=ЕСЛИОШИБКА(ВПР(ВПР(СТРОКА(A1);Таблица8;12;0);$E$2:$F$18;2;0);"")
 

cell.Offset(0,2)=Application.UserName
 

Activesheet.Unprotect Password:="123"

Activesheet.Protect Password:="123"

Private Sub Worksheet_Change(ByVal Target As Range)
    For Each cell In Target   'проходим по всем измененным ячейкам
    If Not Intersect(cell, Range("B4:I120";)) Is Nothing Then
      With Range("A" & cell.Row)
         .Value = Date
         .EntireColumn.AutoFit
      End With
    End If
    Next cell
End Sub

If Not Intersect(cell, Range("A2:A100")) Is Nothing And cell Like "Исправлено*" Then   

Private Sub Worksheet_Change(ByVal Target As Range)
        For Each cell in Target
         If Not Intersect(cell, Range("A2:A100")) Is Nothing And _
                                       Target.Offset(0,1)="" Then
                With Target.Offset(0, 1)
                    .Value = Now
                    .EntireColumn.AutoFit
                End With
       End If
    Next cell
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
        For Each cell in Target
         If Not Intersect(cell, Range("A2:A100")) Is Nothing And _
                                       Target.Offset(0,1)="" Then
                With Target.Offset(0, 1)
                    .Value = Now
                    .EntireColumn.AutoFit
                End With
       End If
    Next cell
End Sub
 

 Private Sub Worksheet_Change(ByVal Target As Range)
        For Each cell In Target
         If Not Intersect(cell, Range("B2:B100")) Is Nothing And _
                                       Target.Offset(0, -1) = "" Then
                With Target.Offset(0, -1)
                    .Value = Now
                    .EntireColumn.AutoFit
                End With
       End If
    Next cell
End Sub

Function iVal(iOper As String) 
' iOper - в моем случае ФИО сотрудника (может быть любое текстовое значение)
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "Данные изменил:"
        .ErrorTitle = ""
        .InputMessage = "ФИО: " & iOper & Chr(10) & "Время: " & Time & Chr(10) & "Дата: " _
            & Date & Chr(10) & "Компьютер: " & Environ("COMPUTERNAME") & Chr(10) & "Пользователь: " _ 
      & Environ("USERNAME")
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
End Function
 

 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 Then
   Target.Offset(, 2) = Date
   Target.Offset(, 4) = Time
   End If
End Sub

 Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("B2:B100")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2:A100
            With cell.Offset(0, -1)         'вводим в соседнюю справа ячейку дату
               .Value = Date
               .EntireColumn.AutoFit  'выполняем автоподбор ширины для столбца B, чтобы дата умещалась в ячейке
            End With
       End If
    Next cell
End Sub

EntireColumn.AutoFit

Columns("C:C").ColumnWidth = 14# 

With ActiveSheet.Cells(1,cell.Column)

Private Sub Worksheet_Change(ByVal Target As Range)   
    For Each cell in Target   'проходим по всем измененным ячейкам
    If Not Intersect(cell, Range("A2:N1000")) Is Nothing Then  
      With Range("O" & cell.row)
         .Value = Now
         .EntireColumn.AutoFit  
      End With
    End If
    Next cell
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
        For Each cell in Target
         If Not Intersect(cell, Range("A2:A100")) Is Nothing And _
                                       Target.Offset(0,1)="" Then
                With Target.Offset(0, 1)
                    .Value = Now
                    .EntireColumn.AutoFit
                End With
       End If
    Next cell
End Sub
 

Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell in Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A2:A100")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2:A100
            With cell.Offset(0, 1)         'вводим в соседнюю справа ячейку дату в комментарий
               .AddComment
               .Comment.Text Text:=Date
            End With
       End If
    Next cell
End Sub

            With cell
                Application.EnableEvents=False
               .AddComment
               .Comment.Text Text:=Date
               Application.EnableEvents=True
            End With

Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("H7:CH1000")) Is Nothing Then
            If Target.Column Mod 2 = 0 Then  'если вводят в четный столбец, то добавляем дату слева
                With cell.Offset(0, -1)
                   .Value = Now
                   .EntireColumn.AutoFit
                End With
            End If
       End If
    Next cell
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    For Each cell In Target 
       If Not Intersect(cell, Range("F4:AO1000")) Is Nothing Then
            With Range("D" & cell.Row)
               .Value = Now
               .EntireColumn.AutoFit
            End With
       End If
    Next cell
End Sub
 

 Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
    If Target.Offset(0, 1).Value = "" Then
    Target.Offset(0, 1) = Date
    Target.Offset(, 2) = Format(Now, "hh:nn";)
    End If
End If
End Sub

Function CursBNM(ByVal CurrencyName As String, ByVal RateDate As Date) As Double'  
функция возвращает курс валюты CurrencyName на дату RateDate'  
в случае ошибки (неверная дата или название валюты) возвращается 0  
On Error Resume Next 
Dim CurrencyRate As Double 
CurrencyName = UCase(CurrencyName): If Len(CurrencyName) <> 3 Then Exit Function 
Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False 
'url_request = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=" + Format(RateDate, "dd\/mm\/yyyy") 
url_request = "http://www.bnm.md/ru/official_exchange_rates?get_xml=1&date=" & Format(RateDate, "dd.mm.yyyy") 
If xmldoc.Load(url_request) <> True Then Exit Function ' Запрос к серверу ЦБР 
' Обработка полученного ответа 
Set nodeList = xmldoc.SelectNodes("ValCurs"): Set xmlNode = nodeList.Item(0).CloneNode(True) 
Set node_attr = xmlNode.Attributes(0): strDate = node_attr.Value 
Set nodeList = xmldoc.SelectNodes("*/Valute") 
For i = 0 To nodeList.Length - 1 ' поиск нужной валюты 
Set xmlNode = nodeList.Item(i).CloneNode(True) 
If xmlNode.ChildNodes(1).Text = CurrencyName  
ThenCurrencyRate = Val(Replace(xmlNode.ChildNodes(4).Text, ",", ".")) 
divisor = Val(Replace(xmlNode.ChildNodes(2).Text, ",", ".")) 
CursBNM = CurrencyRate / divisor 
Exit Function 
End  If 
Next 
End Function
 

Private Sub Worksheet_Change(ByVal Target As Range)
     For Each cell in Target
      If Not Intersect(cell, Range("A2:A100")) Is Nothing And _
                     Target.Offset(0,1)="" Then
          With Target.Offset(0, 1)
           .Value = Now
           .EntireColumn.AutoFit
          End With
    End If
    Next cell
End Sub
  

Application.Volatile False

If IsEmpty(Target) Then
     Target(1, 2) = Empty 

Private Sub Worksheet_Change(ByVal Target As Range)
     For Each cell in Target
      If Not Intersect(cell, Range("A2:A100")) Is Nothing And _
                     Target.Offset(0,1)="" Then
          With Target.Offset(0, 1)
           .Value = Now
           .EntireColumn.AutoFit
          End With
    End If
    Next cell
End Sub
 

 Target.Offset (0,1)

Private Sub Worksheet_Change(ByVal Target As Range)
    For Each cell In Target
    If Not Intersect(cell, Range("B:B") ) Is Nothing And _
    Target.Offset(1, 0) = "" Then
      If IsEmpty(Target) Then
      Target(1, 0) = Empty
Else
     With Target(1, 0)
     .Value = Now
     .EntireColumn.AutoFit
     End With
End If
    End If
    Next cell
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)   
    For Each cell in Target   'проходим по всем измененным ячейкам
    If Not Intersect(cell, Range("D:D")) Is Nothing Then  
      With Range("A" & cell.row)
         .Value = Now
         .EntireColumn.AutoFit  
      End With
    End If
    Next cell
End Sub 

Private Sub Worksheet_Change(ByVal Target As Range)
       On Error Resume Next
       Application.EnableEvents = False
       Target.Offset(-1, 0).Value = Date
       Application.EnableEvents = True
End Sub

Private Sub Worksheet_Calculate()
Dim target As Range
Dim Cell As Variant

Set target = Range("A3:A100")
For Each Cell In target.Cells
    If Cell.Offset(0, 1).Value = "" Then
     Cell.Offset(0, 1) = Date
     Cell.Offset(, 2) = Format(Now, "hh:nn")
    End If
Next Cell

End Sub
 

Sub Сохранение()

'ActiveSheet.Unprotect Password:="qawsed" 'снятие защиты изменения
    Range("B4:I4").Select
        Range(Selection, Selection.End(xlDown)).Select
           Sheets("База").Select
            'ActiveSheet.Unprotect Password:="qawsed"
    Sheets("Шахматка").Select
    Selection.Copy
    Sheets("База").Select
    Range("B2").Select
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Columns("A:I").Select
    Selection.Locked = True
    Selection.FormulaHidden = False
       'ActiveSheet.Protect Password:="qawsed" 'активация защиты
        Sheets("Шахматка").Select
            'ActiveSheet.Unprotect Password:="qawsed"
   Rows("4:254").Select
    Selection.Delete Shift:=xlUp
    'Здесь нужно остановить "Privat Sub
    'ActiveSheet.Unprotect Password:="qawsed"
    Sheets("Data").Select
       Range("D1:K250").Select
               Selection.Copy
         Sheets("Шахматка").Select
         Range("A4").Select
         ActiveSheet.Paste
    'ActiveSheet.Protect Password:="qawsed" 'активация защиты
    'А здесь снова включить
End Sub
 

      iCriteria1 = ">=" & Format(Me.TextBox1.Text, "#")
                iCriteria2 = "<=" & Format(Me.TextBox2.Text, "#")
                Range("A1").AutoFilter Field:=2, Criteria1:=iCriteria1, Operator:=xlAnd, Criteria2:=iCriteria2 

 

  Range("A1").AutoFilter Field:=2, Criteria1:=">=TextBox1.Text", Operator:=xlAnd, Criteria2:="<=TextBox2.Text" 

If TextBox1 <> "" Then
            ElseIf TextBox2 <> "" Then
                iCriteria1 = ">=" & Format(Me.TextBox1.Text, "#")
                iCriteria2 = "<=" & Format(Me.TextBox2.Text, "#")
                  Range("A1").AutoFilter Field:=2, Criteria1:=iCriteria1, Operator:=xlAnd, Criteria2:=iCriteria 
            End If
 

Private Sub Worksheet_Change(ByVal Target As Range)

For Each cell In Target
 If Not Intersect(cell, Range("A6:A300")) Is Nothing Then
  With Range("C" & cell.Row)
   Application.Calculation = xlManual
   .Value = Now
     Application.Calculation = xlAutomatic
.EntireColumn.AutoFit
     End With
    End If
   Next cell
End Sub 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B:O")) Is Nothing Then
      If Len(Target) Then
         Application.EnableEvents = False
         With Cells(Target.Row, 1)
            If .Value = "" Then
                 .Value = Now
                 .EntireColumn.AutoFit
             End If
         End With
      End If
    End If
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 On Error GoTo A
    If Not Intersect(Target, Range("B:O")) Is Nothing Then
      If Len(Target) Then
         Application.EnableEvents = False
         With Cells(Target.Row, 13)
            If .Value = "" Then
                 .Value = Date 'положение Now выводит дату с временем, положение Date выводит только дату
             End If
         End With
      End If
    End If
    Application.EnableEvents = True
A: Exit Sub
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell In Target   '
       If Not Intersect(cell, Range("J2:J100")) Is Nothing Then  '
            With cell.Offset(0, 1)         '
               .Value = Now
               .EntireColumn.AutoFit  '
            End With
       End If
    Next cell
    For Each cell In Target   '
       If Not Intersect(cell, Range("J2:J100")) Is Nothing And cell Like "утверждено*" Then  '
            With cell.Offset(0, -8)         '
               .Value = Now
               .EntireColumn.AutoFit  '
            End With
       End If
    Next cell
End Sub
 

And cell Like "утверждено*"

And cell Like "*.*"

 Sub Занято()  If Not Intersect(ActiveCell, Range("J14:M350") Is Nothing Then ActiveCell = Format(Now, "hh:mm" & "-занято" 
 ActiveCell.EntireRow.Cells(12) = Date ' дата в столбец 12 той же строки
End Sub 

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        With Target
            If .Count > 1 Then Exit Sub
            If Not Intersect(Range("l3:l100"), .Cells) Is Nothing Then
                Application.EnableEvents = False
                If IsEmpty(.Value) Then
                    .Offset(0, 1).ClearContents
                Else
                    With .Offset(0, 1)
                        .NumberFormat = "dd.m.yyyy hh:mm:ss"
                        .Value = Now
                    End With
                End If
                Application.EnableEvents = True
            End If
        End With
    End Sub 

Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each Cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(Cell, Range("A5:A4000")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2
            If IsEmpty(Target) Then
                Target(1, 13) = Empty
                Else
                    With Target(1, 13)
                        .Value = Date
                    End With
            End If
       End If
       If Not Intersect(Cell, Range("L5:L4000")) Is Nothing Then  'если изменененная ячейка попадает в диапазон L2
            If IsEmpty(Target) Then
                Target(1, 4) = Empty
                Else
                    With Target(1, 4)
                        .Value = Date
                    End With

            End If
        End If
        If Not Intersect(Cell, Range("L5:L4000")) Is Nothing Then  'если изменененная ячейка попадает в диапазон L2
              With Cell.Offset(0, 1)
                       Cell.Font.Color = RGB(112, 173, 71)
              End With
        End If
    Next Cell
End Sub

Rows.Font.Color = RGB(112, 173, 71) 

Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("E2:E10000")) Is Nothing And cell Like "Заказана*" Then  'если изменененная ячейка попадает в диапазон A2:A100
            With cell.Offset(0, 1)         'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit 'выполняем автоподбор ширины для столбца B, чтобы дата умещалась в ячейке
        If Not Intersect(cell, Range("E2:E10000")) Is Nothing And cell Like "Принята*" Then
                With cell.Offset(0, 2)         'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit 'выполняем автоподбор ширины для столбца B, чтобы дата умещалась в ячейке
        If Not Intersect(cell, Range("E2:E10000")) Is Nothing And cell Like "Выдана*" Then
                With cell.Offset(0, 3)         'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit 'выполняем автоподбор ширины для столбца B, чтобы дата умещалась в ячейке
            End With
       End If
    Next cell
End Sub
 

Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("E2:E10000")) Is Nothing And cell Like "Заказана*" Then  'если изменененная ячейка попадает в диапазон с условием
            With cell.Offset(0, 1)         'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit 'выполняем автоподбор ширины для столбца, чтобы дата умещалась в ячейке
             End With
       End If
       If Not Intersect(cell, Range("E2:E10000")) Is Nothing And cell Like "Принята*" Then  'если изменененная ячейка попадает в диапазон с условием
            With cell.Offset(0, 2)         'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit 'выполняем автоподбор ширины для столбца, чтобы дата умещалась в ячейке
             End With
       End If
       If Not Intersect(cell, Range("E2:E10000")) Is Nothing And cell Like "Выдана*" Then  'если изменененная ячейка попадает в диапазон с условием
            With cell.Offset(0, 3)         'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit 'выполняем автоподбор ширины для столбца, чтобы дата умещалась в ячейке
             End With
       End If
    Next cell
End Sub 

function myFunction() {
Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A2:A100")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2:A100
            With cell.Offset(0, 1)         'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit  'выполняем автоподбор ширины для столбца B, чтобы дата умещалась в ячейке
            End With
       End If
    Next cell
End Sub
}

Private Sub Worksheet_Change(ByVal Target As Range)
    
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A3:A1000" Is Nothing Then 'если изменененная ячейка попадает в диапазон A2:A1000
        If IsEmpty(Target) Then 'проверяем на удаление информации
            Target(1, 2) = Empty 'усли пусто - тогда очистить дату
            Else ' иначе
                With Target(1, 2) 'в ячейку с указанным смещением
                .Value = Now 'ввести дату
                .EntireColumn.AutoFit
                End With
            End If
       End If
    Next cell 'к следующей ячейке
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A3:A1000")) Is Nothing Then 'если изменененная ячейка попадает в диапазон A2:A1000
        If IsEmpty(Target) Then 'проверяем на удаление информации
            Target(1, 2) = Empty 'усли пусто - тогда очистить дату
            Else ' иначе
                With Target(1, 2) 'в ячейку с указанным смещением
                .Value = Now 'ввести дату
                .EntireColumn.AutoFit
                End With
            End If
       End If
    Next cell 'к следующей ячейке
End Sub 

=ЕСЛИ(A1<>"";ЕСЛИ(B1="";СЕГОДНЯ();B1);"") 

Private Sub Worksheet_Change(ByVal Target As Range)
       
       For Each cell In Target ' проходим по всем измененным ячейкам
        
                
        If Not Intersect(cell, Range("U2:U3035")) Is Nothing Then ' если измененная ячейка попадает в диапазон U2:U3035
        If Len(Target) Then
        With Range("V" & cell.Row) ' вводим в столбец V
        .Value = Sheets("Данные").Range("V3")
        End With
        End If
               
              
        End If
        
        Next cell
        End Sub 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewCellValue$, OldComment$
Dim cell As Range
     
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("A4:A2000")) Is Nothing Then Exit Sub
     
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("A4:A2000"))
        If IsEmpty(cell) Then
            NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки
        Else
            NewCellValue = cell.Formula     'или ее содержимое
        End If
        On Error Resume Next
         
        With cell
           
        End With
        
        ' ==============================================
        ' дополнительый блок
        ' ==============================================
        Row_ = Target.Row ' запоминаем текущую строку на данной странице. такая же строка будет и на странице истории обслуживания
        Col_ = 5   ' устанавливаем крайний левый столбец. 
        
        Do While "" <> Sheets("Лист1").Cells(Row_, Col_).Text ' в цикле считаем заполненные столбцы от крайнего левого столбца. Находим крайний левый пустой столбец на странице истории
                 Col_ = Col_ + 1
        Loop
        ' записываем в пустой столбец на странице истории историю изменения. Тут ее можно компоновать как хочется.
        Sheets("Лист1").Cells(Row_, Col_) = Format(NewCellValue, "DD.MM.YY")
                            
        ' ==============================================
        '  конец дополнительного блока
        ' ==============================================
    Next cell 
End Sub  

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewCellValue$, OldComment$
Dim cell As Range
     
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("B4:B2000")) Is Nothing Then Exit Sub
     
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("B4:B2000"))
        If IsEmpty(cell) Then
            NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки
        Else
            NewCellValue = cell.Formula     'или ее содержимое
        End If
        On Error Resume Next
         
        With cell
           
        End With
        
        ' ==============================================
        ' дополнительый блок
        ' ==============================================
        Row_ = Target.Row ' запоминаем текущую строку на данной странице. такая же строка будет и на странице истории обслуживания
        Col_ = 4   ' устанавливаем крайний левый столбец. ВНИМАНИЕ! Если вы удалите столбец 5 на странице истории, надо установить эту константу на 1 меньше!
        
        Do While "" <> Sheets("Лист1").Cells(Row_, Col_).Text ' в цикле считаем заполненные столбцы от крайнего левого столбца. Находим крайний левый пустой столбец на странице истории
                 Col_ = Col_ + 1
        Loop
        ' записываем в пустой столбец на странице истории историю изменения. Тут ее можно компоновать как хочется.
        Sheets("Лист1").Cells(Row_, Col_) = Format(NewCellValue, "DD.MM.YY")
                            
        ' ==============================================
        '  конец дополнительного блока
        ' ==============================================
    Next cell
    
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A4:A100")) Is Nothing Then  'если изменененная ячейка попадает в диапазон  
                     With cell.Offset(0, 1)      'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit  'выполняем автоподбор ширины для столбца B, чтобы дата умещалась в ячейке
               
            End With
       End If
    Next cell 
End Sub 

Next cell
Worksheets("Лист1").EnableOutlining = True
    Worksheets("Лист1").Protect Password:="1", UserInterfaceOnly:=True
End Sub 

 Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Column = 2 And Target.Row > 1 And Not IsEmpty(Target.Value) And Target.Offset(0, 1).Value = "" Then _
        Target.Offset(0, 1).Value = Date
    If Target.Column = 11 And Target.Row > 1 And Not IsEmpty(Target.Value) And Target.Offset(0, 1).Value = "" Then _
        Target.Offset(0, 1).Value = Date
    If Target.Column = 8 And Target.Row > 1 And Not IsEmpty(Target.Value) And Target.Offset(0, 1).Value = "" Then _
        Target.Offset(0, 1).Value = Date
    If Target.Column = 43 And Target.Row > 1 And Not IsEmpty(Target.Value) And Target.Offset(0, 1).Value = "" Then _
        Target.Offset(0, 1).Value = Date
     If Not Intersect(Target, Range("E2:E99999")) Is Nothing Then
       i = Split(Target.Address, "$")(2)
       LastRow = Sheets("РФ").Cells(Rows.Count, 1).End(xlUp).Row
        If InStr(Cells(i, 4), "РФ") > 0 Then
          Range("A" & CStr(i) & ":E" & i).Copy Sheets("РФ").Range("A" & LastRow + 1)
        End If
     End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim iPRange As Excel.Range
    Set iPRange = Range("C2:C50")
    If Not Application.Intersect(iPRange, Range(Target.Address)) _
               Is Nothing Then
        For Each cell In Target
           If Not iPRange Is Nothing And cell Like "9?????????" Then
                With cell.Offset(0, -1)
                   .Value = "заказано"
                 End With
           End If
        Next cell
    End If
        Set iPRange = Range("B2:C50")
    If Not Application.Intersect(iPRange, Range(Target.Address)) _
               Is Nothing Then
        For Each cell In Target
           If Not iPRange Is Nothing And cell Like "заказано" Then
                With cell.Offset(0, -1)
                   .Value = Now
                 End With
           End If
           If Not iPRange Is Nothing And cell Like "доставлено" Then
                With cell.Offset(0, -1)
                   .Value = Now
                 End With
           End If
           If Not iPRange Is Nothing And cell Like "ждем" Then
                With cell.Offset(0, -1)
                   .Value = Now
                 End With
           End If
        Next cell
    End If
End Sub

 Private Sub Worksheet_Change(ByVal Target As Range)   
    For Each cell in Target   'проходим по всем измененным ячейкам
    If Not Intersect(cell, Range("A2:N1000")) Is Nothing Then  
      With Range("O" & cell.row)
         .Value = Now
         .EntireColumn.AutoFit  
      End With
    End If
    Next cell
End Sub