VBA Code / Duplicating Records

[cidfidou]

Hey Excel Gurus,

I have found online a really good piece of vba code but unfortunelaty I can not update it myself as I am a new to VBA.

The below code duplicate record based on a constant in cell d (ie qty 5) and add an incremental number to the new duplicated records

The issue is that when the output of the macro reaches around 15000 lines it stops working.


Any help on making sure that the macro wont stop and will deliver the desire result even if the total of new records is >than 15k???


Thanks in advance
Initial data

[TABLE="width: 407"]
<tbody>[TR]
[TD]D990304101[/TD]
[TD]US[/TD]
[TD]chicago[/TD]
[TD]qty5[/TD]
[/TR]
[TR]
[TD]D990304109[/TD]
[TD]EU[/TD]
[TD]Paris[/TD]
[TD]qty6[/TD]
[/TR]
</tbody><colgroup><col><col span="3"></colgroup>[/TABLE]

After Macro

[TABLE="width: 407"]
<tbody>[TR]
[TD]D990304101[/TD]
[TD]US[/TD]
[TD]chicago[/TD]
[TD]001[/TD]
[/TR]
[TR]
[TD]D990304101[/TD]
[TD]US[/TD]
[TD]chicago[/TD]
[TD]002[/TD]
[/TR]
[TR]
[TD]D990304101[/TD]
[TD]US[/TD]
[TD]chicago[/TD]
[TD]003[/TD]
[/TR]
[TR]
[TD]D990304101[/TD]
[TD]US[/TD]
[TD]chicago[/TD]
[TD]004[/TD]
[/TR]
[TR]
[TD]D990304101[/TD]
[TD]US[/TD]
[TD]chicago[/TD]
[TD]005[/TD]
[/TR]
[TR]
[TD]D990304109[/TD]
[TD]EU[/TD]
[TD]Paris[/TD]
[TD]001[/TD]
[/TR]
[TR]
[TD]D990304109[/TD]
[TD]EU[/TD]
[TD]Paris[/TD]
[TD]002[/TD]
[/TR]
[TR]
[TD]D990304109[/TD]
[TD]EU[/TD]
[TD]Paris[/TD]
[TD]003[/TD]
[/TR]
[TR]
[TD]D990304109[/TD]
[TD]EU[/TD]
[TD]Paris[/TD]
[TD]004[/TD]
[/TR]
[TR]
[TD]D990304109[/TD]
[TD]EU[/TD]
[TD]Paris[/TD]
[TD]005[/TD]
[/TR]
[TR]
[TD]D990304109[/TD]
[TD]EU[/TD]
[TD]Paris[/TD]
[TD]006[/TD]
[/TR]
</tbody><colgroup><col><col span="2"><col></colgroup>[/TABLE]


Public Sub ExpandRecords()
Dim i As Long, _
j As Long, _
LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Columns("D:D").NumberFormat = "@"
For i = LR To 1 Step -1
If CLng(Right(Range("D" & i).Value, Len(Range("D" & i).Value) - 3)) > 1 Then
With Range("A" & i)
.Offset(1, 0).Resize(CLng(Right(Range("D" & i).Value, Len(Range("D" & i).Value) - 3)) - 1, 1).EntireRow.Insert Shift:=xlDown
.Resize(CLng(Right(Range("D" & i).Value, Len(Range("D" & i).Value) - 3)), 1).EntireRow.Value = Range("A" & i).EntireRow.Value
For j = 1 To CLng(Right(Range("D" & i).Value, Len(Range("D" & i).Value) - 3))
Range("D" & i).Offset(j - 1, 0).Value = Application.Text(j, "000")
Next j
End With
Else
Range("D" & i).Value = Application.Text(1, "000")
End If
Next i
Application.ScreenUpdating = True
End Sub

 

[JoeMo]

I don't know why your code stops working after 15,000 rows, but here's an alternative you can try. This assumes your data start in A1 and produces an expanded listing starting in F1. You can adjust the code to alter these ranges.

Sub ExpandIt()
Dim lR As Long, R As Range, vA As Variant, n As Long, nR As Long
Dim i As Long, j As Long, k As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A1", "D" & lR)
vA = R.Value
nR = 1
Application.ScreenUpdating = False
For i = LBound(vA, 1) To UBound(vA, 1)
    n = Replace(vA(i, 4), "qty", "")
    For j = 0 To 2
        Cells(nR, "F").Offset(0, j).Resize(n, 1).Value = vA(i, j + 1)
    Next j
    For k = 1 To n
        Cells(nR + k - 1, "I").Value = k
    Next k
    nR = Range("F" & Rows.Count).End(xlUp).Row + 1
Next i
Range("I:I").NumberFormat = "000"
End Sub

 

[cidfidou]

Hi Joe

Thank you so much for your reply as it is working perfectly. On top of that your code is much faster than the original one.

I have to say that i am also really impressed and grateful than gifted people like you are ready to help strangers. Thanks again

 

[JoeMo]

Hi Joe

Thank you so much for your reply as it is working perfectly. On top of that your code is much faster than the original one.

I have to say that i am also really impressed and grateful than gifted people like you are ready to help strangers. Thanks again

You are welcome. Thanks for the kind reply.

 

[mirabeau]

The question has of course been very well answered by JoeMo.

However, just for interest, and noting that "Records" sometimes also have formats that may need to be transferred as well as just values, another approach is:

Sub more()
Dim r, x&, c&
c = 1
For Each r In Cells(1).CurrentRegion.Rows
    c = c + x
    x = Split(r.Cells(4), "qty")(1) * 1
    r.Copy Cells(c, 6).Resize(x)
    With Cells(c, 9).Resize(x)
        .Resize(1) = 1
        .DataSeries
        .NumberFormat = "00#"
    End With
Next
End Sub