Deleting cells

I have a range called "Dates". What I would like to happen is that if any date in the range is older than today(), it would delete the information and move up everything else.

Any suggestions?

Thanks

So far I can delete the information in the cell but cannot get the other cells to move up:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rcell As Range

For Each rcell In Range("$A$3", "$M$17")

If rcell.Value < Now Then
rcell.ClearContents

End If
Next
End Sub

The last code i put in is also causing a never ending loop.... Please Help

Okay, I got the loop to stop by adding to my code as below:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rcell As Range

For Each rcell In Range("A3", "M17")

If rcell.Value <> "" Then
If rcell.Value < Now Then
rcell.ClearContents
End If
End If

Next
End Sub

Now, can anyone help with moving the remaining values up. Let's say I had July 2 in cell A3 and July 12 in A4. When A3 is cleared how do I move up the data in A4?

Thanks