Macro for duplicating rows based on cell value?

[Matt.Russett]

Hello,

Below is a sample of a 200 row file I am working with.

LaneID O Zip D Zip Volume
1 44805 24210 18
2 44805 44309 12

What I need to do is duplicate the rows based on the volume for that
lane, so I can load it into an analysis tool we use.

The manual process I am currently using is to insert 17 rows after
Lane ID 1 and fill down the information so I have a total of 18 rows
for that lane. Doing that for over 200 rows is quite tedious! Does
anyone have any suggestions as to how I could set up a macro or
something so it would automatically look at the Volume column, insert
that many rows, and fill the data down?

Any suggestions are greatly appreciated!

Thanks.

 

[David]

Hi,
Hope this does what you want:
Sub Macro1()
Range("A3").Select
Do Until Row = 65536
ActiveCell.Rows("1:17").EntireRow.Select
Selection.Insert Shift:=xlDown
Selection.End(xlDown).Select
If ActiveCell.Row = 65536 Then Exit Do
ActiveCell.Offset(1, 0).Select
Loop
End Sub


David

 

[Bob Phillips]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With ActiveSheet

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = LastRow To 2 Step -1

.Rows(i + 1).Resize(.Cells(i, "D").Value - 1).Insert
.Rows(i).Copy .Cells(i + 1, "A").Resize(.Cells(i, "D").Value -
1)
Next i

End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub



--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Joel]

Sub addcells()

Lastrow = Range("A" & Rows.Count).End(xlUp).Row
StartRow = 2
For RowCount = Lastrow To StartRow Step -1
Volumn = Range("D" & RowCount)
Rows(RowCount).Copy
Rows((RowCount + 1) & ":" & (RowCount + Volumn - 1)).Insert

Next RowCount


End Sub

 

[JLGWhiz]

Might as well try this one.

Sub ExpandRows()
Dim i As Long, lastRw As Long
lastRw = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRw To 1 Step -1
counter = 1
Do Until counter = 18
Range(Cells(i, 1), Cells(i, 4)).Copy
Cells(i + counter, 1).Insert
counter = counter + 1
Loop
Next
Application.CutCopyMode = False
End Sub

 

[JLGWhiz]

Sorry, I missed the part about the Volume criteria. Use this.

Sub ExpandRows()
lastRw = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRw To 2 Step -1
counter = 1
Do Until counter = Cells(i, 4).Value
Range(Cells(i, 1), Cells(i, 4)).Copy
Cells(i + counter, 1).Insert
counter = counter + 1
Loop
Next
Application.CutCopyMode = False
End Sub

 

[Matt.Russett]

Sub addcells()

Lastrow = Range("A" & Rows.Count).End(xlUp).Row
StartRow = 2
For RowCount = Lastrow To StartRow Step -1
Volumn = Range("D" & RowCount)
Rows(RowCount).Copy
Rows((RowCount + 1) & ":" & (RowCount + Volumn - 1)).Insert

Next RowCount

End Sub

I got it to work! Thanks for your help everyone.