Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim iLastRow As Long
Dim iLRow As Long
Dim TimeEda As String
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 If Not Intersect(Target, Range("D2:F" & iLastRow)) Is Nothing Then
 TimeEda = Cells(1, Target.Column)
 With Sheets(TimeEda)
 iLRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
 .Range("A3  " & iLRow).ClearContents
 For i = 2 To iLastRow
 If Not IsEmpty(Cells(i, Target.Column)) And IsNumeric(Cells(i, Target.Column)) Then
 iLRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
 Range(Cells(i, 1), Cells(i, 3)).Copy .Cells(iLRow, 1)
 .Cells(iLRow, 4) = Cells(i, Target.Column)
 End If
 Next
 End With
 End If
End Sub