For Each in Selection, Copy and Paste to Range

[MrHR]

Hi all,

Trying to write one that will let me copy data from each cell in a selection, then paste that value in a set number of blank rows, starting with the next blank in a column.
What I have so far, but rather than pasting the same value 10 times, then the next 10 times, etc., it pastes each value one by one, 10 times over.

Dim c As Excel.Range
For Each c In Selection

Selection.Copy
ActiveSheet.Range("D1").End(xlDown).Offset(1).Resize(10).Select
ActiveSheet.Paste

Next c

Thank you!

 

[My Aswer Is This]

Try this:

Sub Copy_Range()
'Modified  4/9/2021  10:48:15 PM  EDT
Application.ScreenUpdating = False
Dim r As Range

    For Each r In Selection
        r.Copy ActiveSheet.Range("D1").End(xlDown).Offset(1).Resize(10)
    Next

Application.ScreenUpdating = True
End Sub