I have seen code for this but can't get it to work. Keep trying code but getting errors I don't know how to fix.
Trying to solve an issue for a non-profit
They have raffle ticket sales in Column E. So if a person buys 1 ticket they can just print out a card for them, but if they buy 10 tickets I need to get Excel to produce 9 duplicate rows, so the person has 10 total rows.
Thanks for any help
Last edited by Reverend; 05-20-2014 at 09:25 AM. Reason: Added Modified File
Hi there,
here is the code:
And Your file:
Option Explicit Sub DuplicateTickets() Dim sht As Worksheet Dim Xrow, NewRows As Integer Set sht = Sheets("Sheet1") Xrow = 1 Do Until sht.Cells(Xrow, 1) = "" If sht.Cells(Xrow, 5) > 1 Then NewRows = sht.Cells(Xrow, 5) - 1 sht.Cells(Xrow + 1, 1).Resize(NewRows, 1).EntireRow.Insert sht.Cells(Xrow, 1).Resize(1, 4).Copy sht.Cells(Xrow + 1, 1).Resize(NewRows, 4).PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False sht.Cells(Xrow, 5).Resize(NewRows + 1, 1) = 1 Xrow = Xrow + NewRows End If Xrow = Xrow + 1 Loop End Sub
Untitled 1.xls
Hope it helps
Regards
Miroslav R.
(If You like my solutions, feel free to add reputation.)
Try this:-
Regards MickSub MG20May51 Dim Lst As Long Dim n As Long Lst = Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For n = Lst To 1 Step -1 With Range("A" & n) If .Offset(, 4) > 1 Then .Offset(1).Resize(.Offset(, 4) - 1).EntireRow.Insert shift:=xlDown .Offset(1).Resize(.Offset(, 4) - 1, 5).Value = .Resize(, 5).Value End If End With Next n Application.ScreenUpdating = True End Sub
Thanks. Saved a ton of time. Much appreciated
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Reverend 
Register To Reply
Bookmarks