CODEWITHSUNDEEP
excelvba
Baodbao
Baodbao

Reputation: 27

Duplicate line and decrement an ID

How can I repeat rows in a spreadsheet by number of times specified in a cell in that row and decrement an ID in the same row?

E.g. from this table: 

Column A    Column B   Column C  
Peter       123         3   
James       32          7   
David       90          4

I need to produce this table: 

Column A    Column B Column C  
Peter       123         3   
Peter       122         3   
Peter       121         3   
James       32          7   
James       31          7   
James       30          7   
James       29          7   
James       28          7   
James       27          7   
James       26          7   
David       90          4   
David       89          4   
David       88          4   
David       87          4

Find below the code I'm using. 

Public Sub CopyData()
Dim rngSinglecell As Range
Dim rngQuantityCells As Range
Dim intCount As Integer

Set rngQuantityCells = Range("C1", Range("C1").End(xlDown))

For Each rngSinglecell In rngQuantityCells
    If IsNumeric(rngSinglecell.Value) Then
        If rngSinglecell.Value > 0 Then
            For intCount = 1 To rngSinglecell.Value
                Range(rngSinglecell.Address).EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)

            Next
        End If
    End If
Next
End Sub

Upvotes: 0

Views: 57

Answers (1)

Scott Craner
Scott Craner

Reputation: 152505

This quick code will do what you want:

Sub myDup()
    With Worksheets("Sheet3") ' change to your sheet
        Dim rngArr As Variant
        rngArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp)).Value

        Dim outarr As Variant
        ReDim outarr(1 To Application.Sum(Application.Index(rngArr, 0, 3)), 1 To 3)

        Dim k As Long
        k = 1

        Dim i As Long
        For i = LBound(rngArr, 1) To UBound(rngArr, 1)
            Dim j As Long
            For j = 1 To rngArr(i, 3)
                outarr(k, 1) = rngArr(i, 1)
                outarr(k, 2) = rngArr(i, 2) - j + 1
                outarr(k, 3) = rngArr(i, 3)
                k = k + 1
            Next j
        Next i

        .Range("A1").Resize(UBound(outarr, 1), 3).Value = outarr
    End With
End Sub

Upvotes: 2

Related Questions