Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A2:A100")) Is Nothing Then Target.Offset(0, 1) = Date
End Sub

Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Sub Macros()
Dim xlUchet As Excel.Workbook
Dim xlPers As Excel.Workbook
Dim SheetUchet As Worksheet
Dim SheetPers As Worksheet
Dim Path_New As String, Path_Old As String
Path_New = ThisWorkbook.Path & "\New\"
Path_Old = ThisWorkbook.Path & "\Old\"
Set xlUchet = ActiveWorkbook
XlsPath = Path_New & "*.xls"    'Установка пути к файлам.
Application.ScreenUpdating = False
Application.EnableEvents = False
XlsName = Dir(XlsPath)    'Читает первый файл.
Do While XlsName <> ""    ' Start the loop.
       Set xlPers = Workbooks.Open(Path_New & XlsName)
       xlUchet.Activate
'-----------------------------
       For Each SheetUchet In xlUchet.Sheets
           With SheetUchet
               rA = .Range("A" & .Rows.Count).End(xlUp).Row
               rC = .Range("C" & .Rows.Count).End(xlUp).Row
               iRow = IIf(rA > rC, rA, rC + 1)
               For Each SheetPers In xlPers.Sheets
                   If .Name = SheetPers.Name Then
                       rN = SheetPers.Range("A" & SheetPers.Rows.Count).End(xlUp).Row - 1
                       .Range("C" & iRow) = rN
                       .Range("D" & iRow) = Date
                       Ost = IIf(rA > rC, .Range("A" & iRow), .Range("F" & iRow - 1))
                       If Ost - rN > 0 Then
                           .Range("F" & iRow) = Ost - rN
                       Else
                           .Range("F" & iRow) = 0
                           .Range("A" & iRow + 1) = "заказ закрыт"
                           .Range("B" & iRow + 1) = Date
                           .Range("C" & iRow + 1) = .Range("A" & rA) + rN - Ost
                           .Range("D" & iRow + 1) = Date
                           .Range("E" & iRow + 1) = rN - Ost
                       End If
                   End If
               Next
           End With
       Next
'-----------------------------
       xlPers.Close
       MoveFile Path_New & XlsName, Path_Old & XlsName
       XlsName = Dir    'перейти к следующему файлу.
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
'xlUchet.Save 'чтобы файл автоматически записывался снять одинарный апостроф в начале
End Sub