Amend code to run faster

I have the following code kindly supplied to me by someone else and I'd like to know if anyone can suggest any ways to speed up the running of it. It currently takes about 4 minutes to run (there are about 5000 cells to loop through)

Basically it looks for a value in Col C - works out the number of rows to fill up by searching a range in Col D - then copies value in Col C up by that number of rows.

Sub Fill_In_Reason()
Dim lastRow As Long
Dim myRow As Long
Dim myCel As String
Dim myRng As String
lastRow = Range("C65530").End(xlUp).Row
    For Each cell In Range("C2:C" & lastRow).SpecialCells(xlCellTypeConstants, 23)
        myCel = cell.Address
        Debug.Print cell.Address
        myRow = Range(myCel).Row
With Range("D2:D" & myRow).SpecialCells(xlCellTypeConstants)
    myRng = Range("D2:D" & lastRow).SpecialCells(xlCellTypeConstants).Areas(.Areas.Count).Offset(0, -1).Address
    Range(myCel).Copy Range(myRng)
End With
    Next cell
End Sub

Any help would be appreciated

Regards

Seamus