Copy and insert rows with contents and format based on specific number

Hi ,
I have this excel sheet. What I was wondering is how to copy and insert the contents of the row in the same sheet when i click the button.
For example, if Column D ie.Repetation is 4, then the contents from e10 to s10 will get copies 4 times below e10
then if on d18 if the repetation is 6, then the the contents from e18 to s18 will get copies 6 times below e18
then if on d32 if the repetation is 3, then the the contents from e32 to s32 will get copies 6 times below e32

All I want is to have a common code so that I can copy and use the same in different sheets where there are more test subjects.ie.Column D is having more than 10-15 test.

I am uploading the excel file for your reference.
Thanks in advance,

Your sample workbook should have BEFORE/AFTER sheets so we can see clearly what you have in mind.

Should your data be copied along with the merging?

This should do it:

Option Explicit

Sub Repititions()
Dim NumRNG As Range, CellGrp As Range, Rpts As Long

Application.ScreenUpdating = False
With ActiveSheet
    Set NumRNG = .Range("D:D").SpecialCells(xlConstants, xlNumbers)
    
    For Each CellGrp In NumRNG
        For Rpts = 1 To CellGrp.Value - 1
            CellGrp.MergeArea.Resize(, 16).Copy
            CellGrp.Offset(1).Resize(, 16).Insert xlShiftDown
            CellGrp.Offset(1).Value = ""
        Next Rpts
    Next CellGrp
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Remove the button. Run the macro from the Alt-F8 popup list. Now you can't double run the macro that easily. (chuckle)


If that takes care of your original need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.

Right ... thanks.

No, but it can be rewritten completely.

Option Explicit

Sub Repititions()
Dim NumRNG As Range, NumNext As Range, Rpt As Long, Rws As Long

Application.ScreenUpdating = False
With ActiveSheet
    Set NumRNG = .Range("D10")
    Do
        Rpt = NumRNG.Value
        Rws = NumRNG.MergeArea.Rows.Count
        Select Case Rpt
            Case 0
                Set NumNext = NumRNG.Offset(-1)
                NumRNG.MergeArea.Resize(, 16).Delete xlShiftUp
                Set NumRNG = NumNext.End(xlDown)
            Case 1
                'do nothing
                Set NumRNG = NumRNG.End(xlDown)
            Case Else
                NumRNG.MergeArea.Resize(, 16).Copy
                NumRNG.Resize(Rws * (Rpt - 1), 16).Insert xlShiftDown
                Set NumRNG = NumRNG.End(xlDown)
        End Select
    Loop Until NumRNG.Row = Rows.Count
    
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub