Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each Cell In Target   
       If Not Intersect(Cell, Range("B2:B1001")) Is Nothing Then  
            With Cell.Offset(0, -1)        
               .Value = Now
            End With
       End If
    Dim mRng As Range
    Dim ln As Long
    ln = Cells(Rows.Count, 2).End(xlUp).Row
Set mRng = Range(Cells(ln, 2), Cells(ln, 1))
    mRng.Copy Sheets("Ëèñò2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Range(Cells(ln + 1, 2), Cells(ln + 1, 1)).Select
    Next Cell
End Sub

Sub WhCheck()
Dim Wh As Worksheet
For Each Wh In Worksheets 'для каждого листа в книге
If Wh.Name <> "Лист 1" Then 'проверяем имя, чтобы не Лист 1
With Wh
Dim lngI As Long
    lngI = .Cells(Rows.Count, 1).End(xlUp).Row 'Определяем номер последней строки по столбцу А
    .Rows(lngI & ":" & lngI - 4).Delete shift:=xlUp 'удаляем строки от последней заполенной и еще назад 4 строки
    .Range("A1").FormulaR1C1 = "=MID(R[3]C[2],SEARCH(""20"",R[3]C[2])+5,10)"
     Wh.Name = .Range("A1")
    .Range("A1").ClearContents
    .Range("C9") = "Время"
    .Range("B9").ClearContents
    .Columns("B:B").Delete shift:=xlToLeft
    End With
End If
Next
Application.DisplayAlerts = False
With ActiveWorkbook
.Sheets("Лист 1").Delete
End With
Application.DisplayAlerts = True
MsgBox "ПОДГОНКА ТАБЛИЦ ЗАВЕРШЕНА! СОХРАНИТЕ ВЫГРУЗКУ!"
End Sub

Dim Wh As Worksheet
        For Each Wh In Worksheets 'для каждого листа в книге
        If Wh.Name <> "Лист1" Then 'проверяем имя, если не лист1
    With Wh
    Dim lngI As Long
        lngI = Cells(Rows.Count, 1).End(xlUp).Row 'определяем номер последней заполненной ячейки по столбцу А
        Rows(lngI & ":" & lngI - 1).Delete shift:=xlUp 'удаляем строки от последней заполненной и еще назад 4 строки
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=MID(R[3]C[2],SEARCH(""20"",R[3]C[2])+5,10)" 'ищу ИМЯ для листа в ячейке 
    ActiveSheet.Name = Range("A1").Text
    Range("A1").Select
    Selection.ClearContents
    Range("B9").Select
    Selection.Cut
    Range("C9").Select
    ActiveSheet.Paste
    Columns("B:B").Select
    Selection.Delete shift:=xlToLeft
    Range("A1").Select
End With
End If
Next
End Sub

Sub iDelSort()
Dim i As Long
Dim n As Integer
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    n = 1
  For i = 1 To iLastRow
    If Cells(i, 2) <> 0 Then
      Range(Cells(i, 1), Cells(i, 2)).Copy Cells(n, 6)
      n = n + 1
    End If