Duplicating Rows Based On A Cell Value

[adamtest1]

Hi - Does anyone happen to know of a formula or macro that could bacially duplicate rows based on a cell value? The situation is, I have two columns of data; column A is a name and column B is the number of sweepstakes entries they should receive (1-5). These people will be entered into a sweepstakes and will receive muliple entries based on column B (giving them a better chance to win). When pulling random winners, we usually use the formula =RAND and then sort that list from biggest to smallest, giving the biggest number the prize. Since we have to multiply the people's chances based on column B, is there a better way to do this?

I was thinking about simply duplicating the rows based on coulmn B and then =RAND like we usually do, but I'm not sure how to accomplish this.

As an example, this:

Adam 1
Barry 3
Charles 0
David 2

Would be this:

Adam
Barry
Barry
Barry
David
David

And then we would randomize, picking the winner.

Any thoughts?

 

[Joe4]

Welcome to the Board!

This macro will copy the data from Sheet1 to Sheet2, repeating the number of times indicated. Note that you will need to indicate the source starting row and destination starting row in the VBA code. Currently, I have it to start looking at data in cell A2 on Sheet1, and it pastes data on Sheet2 starting in cell A1.

Sub MyCopy()
 
    Dim myStartRow As Long
    Dim myDestRow As Long
    Dim myLastRow As Long
    Dim i As Long
    Dim myLoopCount As Long
 
    Application.ScreenUpdating = False
 
'   Set row to start on sheet 1
    myStartRow = 2
    
'   Set row to start on sheet 2
    myDestRow = 1
    
'   Count total rows on sheet 1
    Sheets("Sheet1").Activate
    myLastRow = Cells(Rows.Count, "A").End(xlUp).Row
        
'   Loop through all people and place on sheet 2
    For i = myStartRow To myLastRow
        myLoopCount = Sheets("Sheet1").Cells(i, "B")
        If myLoopCount > 0 Then
            For j = 1 To myLoopCount
                Sheets("Sheet2").Cells(myDestRow, "A") = Sheets("Sheet1").Cells(i, "A")
                myDestRow = myDestRow + 1
            Next j
        End If
    Next i
    
    Application.ScreenUpdating = True
        
End Sub

 

[John Davis]

Hi - Does anyone happen to know of a formula or macro that could bacially duplicate rows based on a cell value? The situation is, I have two columns of data; column A is a name and column B is the number of sweepstakes entries they should receive (1-5). These people will be entered into a sweepstakes and will receive muliple entries based on column B (giving them a better chance to win). When pulling random winners, we usually use the formula =RAND and then sort that list from biggest to smallest, giving the biggest number the prize. Since we have to multiply the people's chances based on column B, is there a better way to do this?

I was thinking about simply duplicating the rows based on coulmn B and then =RAND like we usually do, but I'm not sure how to accomplish this.

As an example, this:

Adam 1
Barry 3
Charles 0
David 2

Would be this:

Adam
Barry
Barry
Barry
David
David

And then we would randomize, picking the winner.

Any thoughts?

Maybe:

Sub adamtest1()
Dim i As Long
Dim lr As Long
Dim x As Integer

lr = Cells(Rows.Count, 1).End(3).Row

For i = lr To 2 Step -1

x = Range("B" & i).Value

    If Range("B" & i).Value > 1 Then
        
        Range("A" & i).Copy
    
        Range("A" & i).Resize(x).Insert shift:=xlDown
        
        Range("B" & i).Clear
        
    End If
    
    If Range("B" & i).Value < 1 Then Range("A" & i).Delete shift:=xlUp
    
Next i



End Sub

 

[John Davis]

Maybe:

Sub adamtest1()
Dim i As Long
Dim lr As Long
Dim x As Integer

lr = Cells(Rows.Count, 1).End(3).Row

For i = lr To 2 Step -1

x = Range("B" & i).Value

    If Range("B" & i).Value > 1 Then
        
        Range("A" & i).Copy
    
        Range("A" & i).Resize(x).Insert shift:=xlDown
        
        Range("B" & i).Clear
        
    End If
    
    If Range("B" & i).Value < 1 Then Range("A" & i).Delete shift:=xlUp
    
Next i



End Sub

Better yet:

Sub adamtest1()
Dim i As Long
Dim lr As Long
Dim x As Integer

lr = Cells(Rows.Count, 1).End(3).Row

For i = lr To 2 Step -1

x = Range("B" & i).Value

    If x > 1 Then
        
        Range("A" & i).Copy
    
        Range("A" & i).Resize(x - 1).Insert shift:=xlDown
        
    End If
    
    If x < 1 Then Range("A" & i).Delete shift:=xlUp
    
    
Next i

Range("B2:B" & lr).Clear

End Sub