Looping Every Nth Row to Copy & Paste Special

[mcwilsong]

I have some code that goes through a range (for example, D1:H10) and for
every 3rd row, it highlights D3:H3, copies it and then moves up one row to D2
and paste specials the value. I'm trying to alter a piece of code I used to
insert the formula in the same cell range that I am copying and pasting, but
I'm missing how to prevent it from not selecting every 3rd row in the range
as it loops.

Here's the code:
-----Begin Code-----
Dim ColsSelection
Dim RowsSelection
Dim RowsBetween
Dim Diff
Dim FinalRange
Dim xCell

Range("D1:H10").Select
ColsSelection = Selection.Columns.Count
RowsSelection = Selection.Rows.Count
RowsBetween = 3
Diff = Selection.Row - 1
Selection.Resize(RowsSelection, 1).Select
Set FinalRange = Selection. _
Offset(RowsBetween - 1, 0).Resize(1, ColsSelection)
For Each xCell In Selection
If xCell.Row Mod RowsBetween = Diff Then
Set FinalRange = Application.Union _
(FinalRange, xCell.Resize(1, ColsSelection))
FinalRange.Select
Selection.Copy
ActiveCell.Offset(-1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Selection.NumberFormat = "0"
End If
Next xCell
Range("A2").Activate

End Sub
-----End Code-----

Specifically, this piece to the code:

Set FinalRange = Application.Union(FinalRange, xCell.Resize(1, ColsSelection))

Tells it to keep adding to the selected range, but I don't want it to keep
adding to the selected range. I want it to move down 4 rows and then select
D6:H6 and copy and paste special value again. I tried commenting out the
Union code, but then it keeps selecting D3:H3 through each loop. Any
suggestions as to how I can get it to stop adding to the selected range?

Thanks for any help.

 

[Per Jessen]

Hi

Try this (not tested):

Sub aaa()
Dim TargetRange As Range
Dim ColsSelection
Dim RowsSelection
Dim RowsBetween
Dim Diff
Dim CopyRange As Range
Dim xCell

Set TargetRange = Range("D1:H10")
ColsSelection = TargetRange.Columns.Count
RowsSelection = TargetRange.Rows.Count
RowsBetween = 3
Diff = Selection.Row - 1
For Each xCell In TargetRange.Columns(1)
If xCell.Row Mod RowsBetween = Diff Then
Set CopyRange = xCell.Resize(1, ColsSelection)
CopyRange.Copy
TargetRange.Cells(1, 1).Offset(off, 0).PasteSpecial
Paste:=xlPasteValues
Application.CutCopyMode = False
TargetRange.Cells(1, 1).Offset(off, 0).Resize(1,
ColsSelection).NumberFormat = "0"
End If
Next xCell
'Range("A2").Activate
End Sub

Regards,
Per

 

[mcwilsong]

Thanks for the reply Per ... I have a few questions about the sample code you
provided. You use the offset command to move down one row and paste the cells
just copied, however, I'm not sure what "off" is supposed to be in this line.

TargetRange.Cells(1, 1).Offset(off, 0).PasteSpecial _
Paste:=xlPasteValues

I took it as meaning the number of rows to offset by, which in my case is
-1. Unfortunately, this particular script didn't work for me, as it copied
the first row range (D1:H1) instead of D3:H3 and it had nowhere to go to
paste special. I tried changing the start of the target range to begin at the
row I wanted to begin the copy (D3), but the code now just skips through
everything and does nothing.

Maybe a bit more background would be helpful. Row 1 contains the column
headings. When I began altering the original code, I realized it only worked
when I included the first row, which is how I was able to get it to fill the
formula to D3:H3.

Now, I wish to copy the formula from D3:H3 and paste special to D2:H2. Then
from D6:H6 to D5:H5. Then from D9:H9 to D8:H8 and so forth.

Another question I have about your code, does it make a huge difference to
use the targetrange command again just to format the cells? Looping through
my original code, I realized that the cells that just received the pasted
formula was already highlighted.

Any ideas as to how I can tweak this code? I think I've hit my Excel VBA
tipping point messing around with this!

 

[mcwilsong]

If anyone is interested, here's how I solved my problem:

Sub CopyPasteEveryNthRow()
Dim ColsSelection
Dim RowsSelection
Dim RowsBetween
Dim Diff
Dim CopyRange As Range
Dim xCell

' Initialize the range to be evaluated.
Range("D2:H743").Select
' Initialize ColsSelection and make it equal to the
' number of columns in the selection.
ColsSelection = Selection.Columns.Count
' Initialize RowsSelection and make it equal to the
' number of rows in your selection.
RowsSelection = Selection.Rows.Count
' Initialize RowsBetween equal to two.
RowsBetween = 2
' Initialize Diff equal to one row less than the first
' row number of the selection.
Diff = Selection.Row - 1
' Resize the selection to be 1 column wide and the same
' number of rows long as the initial selection.
Selection.Resize(RowsSelection, 1).Select
' Loop through each row in the selection and stop when
' the cell to the right of the active cell is empty.
Do Until IsEmpty(ActiveCell.Offset(0, 1))
' Make the row below the active cell the range to
' be copied.
Set CopyRange = Selection. _
Offset(RowsBetween - 1, 0).Resize(1, ColsSelection)
' Copy the selected range.
CopyRange.Copy
' Special paste the values in the active cell. Which is
' one above the row that was copied.
ActiveCell.PasteSpecial xlPasteValues
' Format the newly pasted values as numbers to remove the
' date format.
Selection.NumberFormat = "0"
' Move down two rows to begin the next loop.
ActiveCell.Offset(2, 0).Select
' Iterate loop.
Loop
' Once the loop ends, activate the top left most cell.
Range("A2").Activate

End Sub