Loop specific VBA code for every 15 Rows upto 5000 rows of a sheet

Hi All

Once again thanks to all for improving my knowledge. I am using following code for copy of Named ranges "header" and "Child". Now i want to loop this code for every 15 rows till say 5000 rows in a sheet.

Kindly suggest suitable method.

Regards,

Narasimharao

Dim i As Long

i = Cells(rows.Count, 1).End(xlUp).Row
Range("Header").Copy
Cells(i, 1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False

Cells(rows.Count, "A").End(xlUp).Offset(3, 0).Select
Range("Child").Copy
Cells(i + 3, 1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False

Please use code tags with your code.

Please Login or Register  to view this content.

Hi AB33,

Thank you very much for prompt support. Actually i am looking for a different solution. Probably i did not provide proper requirement. Please find enclosed template. I want to copy "A1:N1" and "A4:N4" upto say 5000 rows for every interval of 15 rows with out disturbing data of any other rows. In existing macro (commented in this sheet), i am fetching data from some other sheet. Initially i am clearing all the data so that my data in Final format is always fetched based on latest
information in the other sheet. Secondly is there any way to retain the color formatting of entire sheet?

Kindly suggest suitably. Thanks once again for prompt support.

Regards,

Narasimharao

Not clear!

"A1:N1" and "A4:N4"
These are headers and you wanted to copy them. How many times? What is up to 500 rows? Is the is limit you want to do down to? Or, you want to copy these two headers every 15 rows and the last row would be 500. Where are the copies going to?

Hi AB33,

Sorry again, probably i was not able to explain properly. If you carefully observe my template and code, i need both these headers to be pasted to respective location with a gap of 15 rows. ie. A1:N1 is to be copied at A16:N16. I have named A1:N1 as 'named range' as "Header". Same way A4:N4 is to be copied at A19:N19 which is named as "Child". This process should continue upto say next 500 rows by maintaining same gap of 15 rows. Note that data in between rows should not get erased while running this copy of the headers.

Hope you have got what i mean. Thank you in advance for reply again.

Look forward to receive suitable suggestions.

Best regards,

Nandula

Please Login or Register  to view this content.

Hi AB33,

Great!!!!!!, wonderful suggestion / solution. I guess so many intellectuals working on this forum are helping each other. I am very much appreciated with the kind of help from the forum members and especially you. Nice that many of the people have made a habit of going through the queries and replying with suggestions / solutions. Lot many things to learn!!!. Thanks again.

Regards,

Narasimharao

Finally i got my solution working perfectly as per my requirement. I am using the complete code as below:

Sub FinalFormat()
Dim LR1, TR, K, HeadRo As Long

Sheets("Final Format").Range("a2:X2000").ClearContents
With Sheets("Sheet1")
LR1 = .Range("A" & rows.Count).End(xlUp).Row

For TR = 2 To LR1
If .Range("A" & TR) <> .Range("A" & TR - 1) Then
.Range("A" & TR & ":K" & TR).Copy Sheets("Final Format").Range("D" & 2 + (HeadRo) * 15)
HeadRo = HeadRo + 1
K = 0
End If
.Range("L" & TR & ":U" & TR).Copy Sheets("Final Format").Range("E" & 5 + K + (HeadRo - 1) * 15)
K = K + 1

Next TR
End With

Dim i2 As Long

i2 = Cells(rows.Count, 1).End(xlUp).Row
Range("Header").Copy
Cells(i2, 1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False

Cells(rows.Count, "A").End(xlUp).Offset(3, 0).Select
Range("Child").Copy
Cells(i2 + 3, 1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False


Dim i As Long, LR&
Application.ScreenUpdating = 0
NR = 16: MR = 19
For i = 1 To 100
Cells(1, 1).Resize(, 14).Copy Cells(NR, 1)
Cells(4, 1).Resize(, 14).Copy Cells(MR, 1)
NR = NR + 15
MR = MR + 15
Next

Application.ScreenUpdating = True

MsgBox "Done"
End Sub

Narasimharao,
Please use code tags with your code.
Glad to know you have got your solution and you are welcome!
Could you please now close (Mark) this thread as solved? Go in to the top right-hand side of this page, choose "Thread Tools" from the menu, then select "solved" from the drop down menu.