Option Explicit
Sub TEST2()
Dim ar, br, i&, j&, r&, k&
Application.ScreenUpdating = False
ar = Worksheets(1).[A9].CurrentRegion.Value
ReDim br(1 To UBound(ar) * 10, 1 To UBound(ar, 2))
For j = 1 To UBound(ar, 2)
br(1, j) = ar(1, j)
Next j
r = 1
For i = 2 To UBound(ar)
r = r + 1
For j = 1 To UBound(ar, 2)
br(r, j) = ar(i, j)
Next j
If ar(i, 6) > 1 Then
For k = 1 To ar(i, 6)
r = r + 1
For j = 1 To UBound(ar, 2)
br(r, j) = ar(i, j)
Next j
br(r, 6) = 1
Next k
End If
Next i
[J9].Resize(r, UBound(br, 2)) = br
Application.ScreenUpdating = True
Beep
End Sub
|