Dim wks As Worksheet
Dim iRow As Long
Dim r As Long
' worksheet containing lines to duplicate
Set wks = Worksheets("test")
With wks
'first row excluded
For iRow = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
'column Q contains how-many-copies
r = .Range("Q" & iRow)
If r > 1 Then
.Range("A" & iRow + 1, "A" & iRow + r - 1).EntireRow.Insert
.Range("A" & iRow, "A" & iRow + r - 1).EntireRow.FillDown
End If
Next iRow
End With
End Sub
Other solution:
In your xl sheet hit alt+f11. This opens the vbe window. Select module from the insert menu and paste the following code. Close the vbe window. Back in xl hit alt+f8, select test and click on run.
Once the pompt comes up, use the mouse to select the entire range to be processed. In this example the column_identifier is set to 1. If the identifier is in some other column, set its value accordingly.
Sub test()
Dim myRange As Range
Dim tSht, nSht, i, j, column_identifier
column_identifier = 1
Set tSht = ActiveSheet: Set nSht = Sheets.Add: tSht.Activate
Set myRange = Application.InputBox(Prompt:="Use your mouse to select the range", Type:=8)
For Each c In myRange.Columns(column_identifier).Cells
For i = 1 To Val(c)
j = j + 1
Range(Cells(c.Row, myRange.Columns(1).Column), Cells(c.Row, myRange. _
Columns(1).Column + myRange.Columns.Count - 1)).Copy nSht.Cells(j, 1)
nSht.Cells(j, myRange.Columns.Count + 1) = i
Next i
Next c
nSht.Activate
End Sub
Source:
Develop excel macro to create duplicate rows of records based on criteria
www.experts-exchange.com/Software/Office_Productivity/Spreadsheets/Q_22744596.html
No comments:
Post a Comment