At each subtotal, for then loop copy and paste above data vba

Question

I am trying to copy each subtotal and paste above each data set using the for then loop. Maybe there is a more appropriate loop to use here I am not 100% sure. I am having trouble getting the loop to copy the subtotal after the condition is met. See code below:

For I = 1000 To 2 Step -1 ' adjust 1000 to the row number of the last element
If Cells(I, 7).Font.Bold Then
    Cells(I + 1, 1).Copy
    Selection.End(xlUp).Select
    Selection.Offset(1, -7).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End If
Next

What I can't get the macro to do is copy the actual subtotal, it doesn't even copy the cell it was selected. In case you need to see what I'm trying to get the loop to do see pic below.

Answer 1

Cells(I + 1, 1).Copy is correctly copying the cell contents, but it isn't actually selecting the cell. Then you are trying to set the destination by moving the selection starting with the selected cell, but the starting point for selection hasn't actually been set by the loop in the first place.

One way to change it is to not use .select until it is time to paste. This is also more efficient because .select is very inefficient and should be minimized.

For I = 1000 To 2 Step -1 ' adjust 1000 to the row number of the last element
If Cells(I, 7).Font.Bold Then
    Cells(I + 1, 7).Copy
    Cells(I + 1, 7).End(xlUp).Offset(1, -6).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End If
Next