VBA code- Copy Paste Multiple rows and adding cell Value

Registration date
Monday December 5, 2016
Last seen
December 5, 2016
- Dec 5, 2016 at 12:40 AM

I need to copy excel rows multiple times based on a cell Value.
I also want to insert the decreasing value based on the loop count.


Title desc Days
Sample Content 6

Needs an output

Title desc Days Counter
Sample Content 6 6
Sample Content 6 5
Sample Content 6 4
Sample Content 6 3
Sample Content 6 2
Sample Content 6 1

I am able to get the copy part with this code. Need help in getting the counter Column added

Public Sub CopyData()
' This routing will copy rows based on the quantity to a new sheet.
Dim rngSinglecell As Range
Dim rngQuantityCells As Range
Dim intCount As Integer

' Set this for the range where the Quantity column exists. This works only if there are no empty cells
Set rngQuantityCells = Range("D1", Range("D1").End(xlDown))

For Each rngSinglecell In rngQuantityCells
' Check if this cell actually contains a number
If IsNumeric(rngSinglecell.Value) Then
' Check if the number is greater than 0
If rngSinglecell.Value > 0 Then
' Copy this row as many times as .value
For intCount = 1 To rngSinglecell.Value
' Copy the row into the next emtpy row in sheet2
Range(rngSinglecell.Address).EntireRow.Copy Destination:= Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
' The above line finds the next empty row.

End If
End If
End Sub