Find blank cell; keep loop after

[bobkap]

In my 4th column - every time there is a blank cell I want to copy the data from the cell above the blank cell and paste it in what was the blank cell. I think I have that part figured out. I need help please on how to continue my loop from THAT cell forward. The closest I can get is for the loop to keep going back to the first row and run again and again. I have over 21K records so the macro either bombs out or runs forever. Is there some way I can get my loop to continue from the point right after it copied and pasted in that blank column?

I have this code so far followed by sample data:
Sub Paste_after_last_row()
'
' Paste_at first blank row
'
'Find the last used row in a sheet and copy and paste data below it.
finalrow = Cells(Rows.Count, 4).End(xlUp).Row
banana = 2
Dim ws As Worksheet
Set ws = ActiveSheet
For banana = 1 To finalrow
For Each cell In ws.Columns(4).Cells
If Len(cell) = 0 Then cell.Select: Exit For
Next cell
ActiveCell.Offset(-1, 0).Activate
ActiveCell.Copy
ActiveCell.Offset(1, 0).PasteSpecial

myrow = ActiveCell.Row
mycol = ActiveCell.Column

Next banana
'
End Sub

 

[footoo]

If column D contains constants, no need to loop :

Sub Paste_after_last_row()
With Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row)
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With
End Sub

Or you can leave the formula in the blank cells :

Sub Paste_after_last_row()
Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub

 

[AlphaFrog]

Sub Paste_after_last_row()
    Dim BlankCell As Range
    
    For Each BlankCell In Range("D2", Cells(Rows.Count, "D").End(xlUp)).SpecialCells(xlCellTypeBlanks)
        BlankCell.Value = BlankCell.Offset(-1).Value
    Next BlankCell
    
End Sub

 

[bobkap]

If column D contains constants, no need to loop :

Sub Paste_after_last_row()
With Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row)
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With
End Sub

Or you can leave the formula in the blank cells :

Sub Paste_after_last_row()
Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub

Thanks very much. I don't mean to sound ungrateful, but each one bombed out saying "no cells found". I must be doing something wrong. I pasted the code in a module and F8'ed it and I got that error.

 

[bobkap]

Sub Paste_after_last_row()
    Dim BlankCell As Range
   
    For Each BlankCell In Range("D2", Cells(Rows.Count, "D").End(xlUp)).SpecialCells(xlCellTypeBlanks)
        BlankCell.Value = BlankCell.Offset(-1).Value
    Next BlankCell
   
End Sub

I really appreciate your help. But, as I did with another solution, I got the "no cells found" error when I tried to run this. If you might be able to point out where I went wrong I would greatly appreciate it.

 

[Fluff]

How about

Sub bobkap()
   With Range("D2", Range("D" & Rows.Count).End(xlUp))
      .Value = .Value
      .SpecialCells(xlBlanks).FormulaR1C1 = "=r[-1]c"
      .Value = .Value
   End With
End Sub

 

[My Aswer Is This]

Try this:
It will popup a message box if no empty cells are found.

Sub Run_Me()
'Modified  3/3/2020  1:17:42 PM  EST
On Error GoTo M
With Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row)
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With
Exit Sub
M:
MsgBox "No empty cells found"
End Sub

 

[My Aswer Is This]

How about

Sub bobkap()
   With Range("D2", Range("D" & Rows.Count).End(xlUp))
      .Value = .Value
      .SpecialCells(xlBlanks).FormulaR1C1 = "=r[-1]c"
      .Value = .Value
   End With
End Sub

When I try this if no empty cell is found I get the same error

 

[bobkap]

Thanks so much, but still same result. It MUST be me?

 

[My Aswer Is This]

Thanks so much, but still same result. It MUST be me?

View attachment 8160

Did you try my code?