Macro for duplicating rows based on cell value?

  • Thread starter Thread starter Matt.Russett
  • Start date Start date
M

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.
 
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
 
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)
 
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
 
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
 
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
 
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
Click to expand...

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