Thursday, January 27, 2011

XL: Duplicate rows for certain number of times

Sub DupLine()
    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