Copy and insert rows based off of values in a column
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
There are a number of issues with your approach and code
- You say the data is in an Excel Table. Use that to your advantage
- When inserting rows into a range loop from the bottom up. This prevents the inserted rows interfering with the loop index
- Don't use Selection (and even if you do your logic doesn't manipulate the ActiveCell)
- 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