Hi Mike,

two things..

1. There's a mistake in my last reply, which I have now fixed up.

2. To cover the possibility of the data reaching the bottom of the
sheet I have included a line that clears the bottom-most row of the
target column so that there is room for moving all the old data down
one row....

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range(Target.Address), Me.Range("A3:G3")) _
Is Nothing Then
Me.Cells(Me.Range("A:A").Rows.Count, Target.Column).Clear
Dim rgOldValues As Range
Dim iLastRow As Long
iLastRow = Me.Cells(Columns(Target.Column).Rows.Count, Target.Column) _
..End(xlUp).Row
Application.EnableEvents = False
Select Case iLastRow
Case 1
Case 2
Case 3
Cells(4, Target.Column).Value = Cells(3, Target.Column).Value
Case Else
Set rgOldValues = Me.Range(Cells(Target.Row + 1, Target.Column), _
Cells(iLastRow, Target.Column))
rgOldValues.Cut _
Destination:=Me.Range(Cells(Target.Row + 2, Target.Column), _
Cells(iLastRow + 1, Target.Column))
Cells(4, Target.Column).Value = Cells(3, Target.Column).Value
End Select
Application.EnableEvents = True
End If
End Sub


Ken Johnson