Hi Ken,

I've been looking at how others achieve the same effect and have
discovered it's a lot easier than I thought. It turns out that all that
is needed to shift all of the old data cells down one row is .Insert
Shift:= xlDown.

Also, the way that I was checking that there was still space on the
sheet for moving the data down one more row was logically flawed, so
I've fixed that up too. The logically correct way also turned out to be
a lot simpler than I originally thought.

So, hopefully my final version is...

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim rngInput As Range
Dim rngCell As Range
Set rngInput = Range("A2") '<<<<<<<<<<<<<<<<<<<<<<
'Edit rngInput's Address String to suit your needs^
'Examples...
' "A2,C2" for A2 and C2
' "D1:G1" for D1, E1, F1 and G1
' "A2,C2,D1:G1" for A2, C2, D1, E1, F1 and G1.
If Not Intersect(Target, rngInput) Is Nothing Then
On Error GoTo ERRORHANDLER
Application.EnableEvents = False
For Each rngCell In Intersect(Target, rngInput)
If rngCell.Value < "" Then
If Cells(Rows.Count, _
rngCell.Column).Value = "" Then
rngCell.Insert shift:=xlDown
With rngCell.Offset(-1, 0)
.ClearContents
.Select
End With
Else: MsgBox "No more room in column " _
& Mid(rngCell.Address, 2, _
WorksheetFunction.Find( _
"$", rngCell.Address, 2) - 2)
End If
End If
Next rngCell
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
End Sub


Ken Johnson