PDA

View Full Version : Solved: insert rows based on cell value



Meatball
05-14-2009, 01:50 PM
Hi, I am trying to create a macro to to insert copied rows and search did have exactly what I am trying so I made this new thread.
I want to read the number in Col D. If it is more than 1, I need to copy the row and insert the copies just below the row in question. The total rows inserted would be 1 less than Col D. So if Row 8 Col D is 5 then copy row 8 and insert copied row into the 4 rows below, 9 thru 12. Then Col D needs to be changed to 1 in all 5 rows.
I also need Col K to be factored in such a way that I can turn the factoring on and off. In other words, in some rows Col K will equal 1. On the first run of the macro I do not want those rows expanded, but on the second run I do. The manor in which that is done is optional, second run of macro, message box to choose yes or no for those rows, 2 different macro's, etc.
I tried to start it but what I saw when searching makes me think I would never get this by myself.
Doing a basic start this is what I came up with. I did not yet try to factor in Col K. It may be useless but I won't learn if I don't do some of this stuff myself so I will compare it to the final result

Option Explicit
Sub QtyExtractor()
Dim i As Integer
Dim lr As Integer
Dim r As Row
lr = Range("A8:T" & Range("A2000").End(xlUp).Row)
i = Range("D")
For Each r In lr
If i > 1 Then
Rows.Copy
'Next Row insert copied cells i-1 rows
'make all column D to 1
Next r
End Sub

Thanks in advance for any help.

Meatball
05-18-2009, 07:38 AM
I am trying to piece together some code to do what I want. The first thing I am trying to do is get 1 row inserted but I am getting a compile error that I can not get past. Right now the error is "Next without For". Can anyone help me with the part after the comment. The comment is for the next step after I get the insert rows part worked out

Sub QtyExtractor()
Dim RangeToCheck As Range
Dim CellInRangeToCheck As Range
Dim i As Long
Set RangeToCheck = Range("A8:Z" & Range("B2000").End(xlUp).Row)
For i = RangeToCheck To 1 Step -1
For Each CellInRangeToCheck In RangeToCheck
If (CellInRangeToCheck.Value > 1) Then
Rows(i).Copy
Rows(i + 1).Insert
'make all column D to 1
Next i
Exit For
End Sub

Meatball
05-18-2009, 10:58 AM
OK, I was able to get to the point where I can insert a row beneath the the ones with Col D greater than 1. Still can not get the copy part or the quantity of rows to insert worked out. Still looking for some help.

Sub QtyExtractor()
Dim x As Long, LastRow As Long

With ActiveSheet

LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For x = LastRow To 8 Step -1
If .Range("D" & x) > 1 Then .Rows(x).Insert Shift:=xlDown

Next x
End With
End Sub

Meatball
05-18-2009, 01:10 PM
Almost finished. I can now copy and insert the number of rows that I want as dictated by the qty in Col D. The only thing needed to finish this is to change the quantity in Col D to 1 for all of the rows copied and pasted. I can not change the whole column due to rows not expanded.

Option Explicit
Sub QtyExtractor()
Dim i As Long
Dim LastRow As Long
Dim Qty As Long
With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 8 Step -1
Qty = .Range("D" & i)
If .Range("D" & i) > 1 And .Range("K" & i).Value = "" Then
.Rows(i).Copy
.Rows(i + 1).Resize(Qty - 1).Insert

End If
Next i
End With
End Sub

georgiboy
05-18-2009, 01:23 PM
Try this...

Option Explicit
Sub QtyExtractor()
Dim i As Long
Dim LastRow As Long
Dim Qty As Long
With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 8 Step -1
Qty = .Range("D" & i)
If .Range("D" & i) > 1 And .Range("K" & i).Value = "" Then
.Rows(i).Copy
.Rows(i + 1).Resize(Qty - 1).Insert
.Range("D" & i).Resize(Qty).Value = 1
End If
Next i
End With
End Sub

Hope this helps

Meatball
05-18-2009, 02:32 PM
georgiboy, thank you for responding. I have actually solved this on my own but I will try your code tomorrow since it would be cleaner looking than my results.
Thanks to all the people who posted in the many threads I looked at to get my code working.
My result for those who might be interested;

Option Explicit
Sub QtyExtractor()
Dim i As Long
Dim x As Long
Dim LastRow As Long
Dim EndRow As Long
Dim Qty As Long
With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 8 Step -1
Qty = .Range("D" & i)

If .Range("D" & i) > 1 And .Range("K" & i).Value = "" Then
.Rows(i).Copy
.Rows(i + 1).Resize(Qty - 1).Insert

End If
Next i
EndRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For x = EndRow To 8 Step -1

If .Range("K" & x).Value = "" Then .Range("D" & x) = 1
Next x

End With

End Sub

Meatball
05-18-2009, 02:37 PM
georgiboy, thank you. your code works as well so I will use it. As they say, "more than one way to skin a cat". Thanks again