Sub CollectDataFromAllSheets()
    Dim ws As Worksheet
     
    Set wbCurrent = ActiveWorkbook
    Workbooks.Add
    Set wbReport = ActiveWorkbook
     
    'копируем на итоговый лист шапку таблицы из первого листа
    wbCurrent.Worksheets(1).Range("A1:D1").Copy Destination:=wbReport.Worksheets(1).Range("A1")
     
    'проходим в цикле по всем листам исходного файла
    For Each ws In wbCurrent.Worksheets
     
        'определяем номер последней строки на текущем листе и на листе сборки
        n = wbReport.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
         
        'задаем исходный диапазон, который надо скопировать с каждого листа - любой вариант на выбор:
        Set rngData = ws.Range("A1:D5")            'фиксированный диапазон или
        Set rngData = ws.UsedRange                 'всё, что есть на листе или
        Set rngData = ws.Range("F5").CurrentRegion    'область, начиная от ячейки F5 или
        Set rngData = ws.Range("A2", ws.Range("A2").SpecialCells(xlCellTypeLastCell))    'от А2 и до конца листа
         
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, 1)
         
    Next ws
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim cl As Range
With Worksheets("Bitki")
    lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
    .Unprotect Password:="1583568383as"
    On Error Resume Next
    For Each cl In .Range("B:XZ" & lRow).Cells
        If Not IsEmpty(cl) Then
            cl.Locked = True
            cl.Offset(, 0).Locked = True
        End If
    Next
    .EnableOutlining = True
    .Protect Password:="1583568383as", UserInterfaceOnly:=True, _
        DrawingObjects:=True, Contents:=True, Scenarios:=True, _
        AllowFiltering:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, _
        AllowSorting:=True
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 2
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    Unprotect Password:="1583568383as"
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).Value = Format(Now, "dd.mm.yyyy")
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next
    Application.EnableEvents = True
    Protect Password:="1583568383as"
End If
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 14
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    Unprotect Password:="1583568383as"
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).Value = Format(Now, "hh:mm")
             Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next
    Application.EnableEvents = True
    Protect Password:="1583568383as"
End If
     
    If Not Intersect(Target, Range("O:O")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
     Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next
    Application.EnableEvents = True
End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim cl As Range
With Worksheets("Techizat izlemesi")
    lRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    .Unprotect Password:="1234as"
    On Error Resume Next
    For Each cl In .Range("A2:XZ" & lRow).Cells
        If Not IsEmpty(cl) Then
            cl.Locked = True
            cl.Offset(, 0).Locked = True
        End If
    Next
    .Protect Password:="1234as", UserinterfaceOnly:=True, _
        DrawingObjects:=True, Contents:=True, Scenarios:=True, _
        AllowFiltering:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, _
        AllowSorting:=True
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("С:С"), Target)
xOffsetColumn = -2
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    Unprotect Password:="123as"
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).NumberFormat = "dd.mm.yyyy"
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next
    Application.EnableEvents = True
    Protect Password:="123as"
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(3)) Is Nothing And Target.Row > 1 And Target.Count = 1 Then
        Me.Unprotect Password:="123as"
        If Len(Target) Then
            On Error Resume Next
            Target.Locked = True
            Target.Offset(, -2).Value = Format(Now, "dd.mm.yyyy")
            Target.Offset(, -2).Locked = True
        End If
        Me.Protect Password:="123as"
    End If
End Sub

1 макрос:

Dim mRg As Range
Dim mStr As String
 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("A2:C100"), Target) Is Nothing Then
    Set mRg = Target.Item(1)
    mStr = mRg.Value
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xRg As Range
    On Error Resume Next
    Set xRg = Intersect(Range("A2:C100"), Target)
    If xRg Is Nothing Then Exit Sub
    Target.Worksheet.Unprotect Password:="123as"
    If xRg.Value <> mStr Then xRg.Locked = True
    Target.Worksheet.Protect Password:="123as"
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("A2:C100"), Target) Is Nothing Then
    Set mRg = Target.Item(1)
     mStr = mRg.Value
End If
End Sub

2 макрос:

Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("C:C"), Target)
xOffsetColumn = -2
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next
    Application.EnableEvents = True
End If
End Sub