Excel duplicate row macro help

[iambadatexcel]

hello everyone! hoping I can get some help with a macro formula. It is the macro called 'AddMulitRows'. It is supposed to take column I and duplicate it by the value in column I, how would I get it to duplicate it by the value in column I minus 1? Current formula below, spreadsheet attached for reference.

>>> use code - tags <<<

Sub AddMulitRows()
   Dim i As Long
  
   For i = Range("I" & Rows.Count).End(xlUp).Row To 2 Step -1
      Rows(i).Copy
      Rows(i).Resize(Range("I" & i)).Insert
   Next i
End Sub

 

[Logit]

Option Explicit

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("I2", Range("I2").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 - 1
                    ' 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.

                Next
            End If
        End If
    Next
End Sub

 

[Marc L]

Hello, according to the single sheet attachment - as it is - a VBA demonstration to paste only to Sheet1 worksheet module :​

Sub Demo1()
   With UsedRange.Rows
        If Application.Count(.Columns(9)) = 0 Then Beep: Exit Sub
    For R& = .Count To 2 Step -1
        S& = .Cells(R, 9) - 1
     If S > 0 Then
       .Cells(R, 9) = Empty
       .Item(R).Copy
       .Item(R).Resize(S).Insert xlShiftDown
     End If
    Next
   End With
        Application.CutCopyMode = False
End Sub

Do you like it ? So thanks to click on bottom right Like !​

​