Copy and insert rows based off of values in a column

Question

I am trying to set up a procedure that looks up cells in Column "G" and if a value is greater than 1, copy that entire table row, insert a row (as many times - 1 based on the value) and paste that value into each newly inserted row.

So if there is a quantity of 3 in cell "G4" then I would like to copy the row of that cell and insert a row below it 2 times and paste the copied values.

Below is what I have so far...

**Note all of this is in a table in Excel. (not sure if that's part the issue with my code)

Dim Qty As Range

 For Each Qty In Range("G:G").cells
  If Qty.Value > 1 Then
   Qty.EntireRow.cell
   Selection.Copy
   ActiveCell.Offset(1).EntireRow.Insert
   Selection.Paste
   Selection.Font.Strikethrough = True

 End If

 Next

 End Sub

Answer 1

There are a number of issues with your approach and code

1. You say the data is in an Excel Table. Use that to your advantage
2. When inserting rows into a range loop from the bottom up. This prevents the inserted rows interfering with the loop index
3. Don't use Selection (and even if you do your logic doesn't manipulate the ActiveCell)
4. Don't loop over the whole column (thats a million rows). Limit it to the table size

Here's a demonstration of these ideas

Sub Demo()
    Dim sh As Worksheet
    Dim lo As ListObject
    Dim rColumn As Range
    Dim i As Long
    Dim rws As Long

    Set sh = ActiveSheet ' <-- adjuct to suit
    Set lo = sh.ListObjects("YourColumnName")

    Set rColumn = lo.ListColumns("YourColumnName").DataBodyRange
    vTable = rColumn.Value

    For i = rColumn.Rows.Count To 1 Step -1
        If rColumn.Cells(i, 1) > 1 Then
            rws = rColumn.Cells(i, 1) - 1
            With rColumn.Rows(i)
                .Offset(1, 0).Resize(rws, 1).EntireRow.Insert
                .EntireRow.Copy .Offset(1, 0).Resize(rws, 1).EntireRow
                .Offset(1, 0).Resize(rws, 1).EntireRow.Font.Strikethrough = True
            End With
        End If
    Next
End Sub