Human_doing
Board Regular
- Joined
- Feb 16, 2011
- Messages
- 137
Hi all,
I have received the below really helpful code on how to copy and paste a random selection of cells to sheet 2 from another user on this forum, can anyone please advise on how to make this code also copy the adjacent cells in Column B to the random Column A selections i.e. if 2 random selections are chosen and are rows 1 and 7, then A1:B1 and A7:B7 are chosen? I am at best an intermediate VBA coder and this is proving beyond me, any help much appreciated!
Thanks
Sub SampleFromRangeWithReplacement()
Dim LR As Long
Dim NbrItems
Dim test As Long
Dim i As Long
Dim j As Long
Dim Results() As Long
Dim GoodMatch As Boolean
NbrItems = InputBox("How many random results are required")
If Not IsNumeric(NbrItems) Then
MsgBox ("Please select a number")
Exit Sub
ElseIf Int(CDbl(NbrItems)) <> CDbl(NbrItems) Then
MsgBox ("Please select a number")
Exit Sub
ElseIf CDbl(NbrItems) <= 0 Then
MsgBox ("Please select a number")
Exit Sub
End If
NbrItems = CLng(NbrItems)
LR = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
If NbrItems >= LR Then
MsgBox ("Not that many results in the sample!!")
Exit Sub
End If
'since we have nbritems to choose, we'll need to make our results array with that number of items
'Results() holds the Row Numbers of the random choices
ReDim Results(1 To NbrItems)
i = 0
Do
If i = NbrItems Then Exit Do
'check to see if result has already been chosen
Do
GoodMatch = True
'formula cribbed from help on rnd()...
test = Int((LR - 2 + 1) * Rnd() + 2)
For j = 1 To i
If test = Results(j) Then
GoodMatch = False
Exit For
End If
Next j
If GoodMatch Then
i = i + 1
Results(i) = test
Exit Do
End If
Loop
Loop
'clear output range on sheet2
Worksheets("Sheet2").Columns(1).Clear
Worksheets("Sheet2").Cells(1, 1) = "Randomiser results"
'now we populate sheet2 using the row numbers placed into the results array
For i = 1 To NbrItems
Worksheets("Sheet2").Cells(i + 1, 1) = Worksheets("Sheet1").Cells(Results(i), 1)
Next i
MsgBox ("Results on sheet 2!")
End Sub
I have received the below really helpful code on how to copy and paste a random selection of cells to sheet 2 from another user on this forum, can anyone please advise on how to make this code also copy the adjacent cells in Column B to the random Column A selections i.e. if 2 random selections are chosen and are rows 1 and 7, then A1:B1 and A7:B7 are chosen? I am at best an intermediate VBA coder and this is proving beyond me, any help much appreciated!
Thanks
Sub SampleFromRangeWithReplacement()
Dim LR As Long
Dim NbrItems
Dim test As Long
Dim i As Long
Dim j As Long
Dim Results() As Long
Dim GoodMatch As Boolean
NbrItems = InputBox("How many random results are required")
If Not IsNumeric(NbrItems) Then
MsgBox ("Please select a number")
Exit Sub
ElseIf Int(CDbl(NbrItems)) <> CDbl(NbrItems) Then
MsgBox ("Please select a number")
Exit Sub
ElseIf CDbl(NbrItems) <= 0 Then
MsgBox ("Please select a number")
Exit Sub
End If
NbrItems = CLng(NbrItems)
LR = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
If NbrItems >= LR Then
MsgBox ("Not that many results in the sample!!")
Exit Sub
End If
'since we have nbritems to choose, we'll need to make our results array with that number of items
'Results() holds the Row Numbers of the random choices
ReDim Results(1 To NbrItems)
i = 0
Do
If i = NbrItems Then Exit Do
'check to see if result has already been chosen
Do
GoodMatch = True
'formula cribbed from help on rnd()...
test = Int((LR - 2 + 1) * Rnd() + 2)
For j = 1 To i
If test = Results(j) Then
GoodMatch = False
Exit For
End If
Next j
If GoodMatch Then
i = i + 1
Results(i) = test
Exit Do
End If
Loop
Loop
'clear output range on sheet2
Worksheets("Sheet2").Columns(1).Clear
Worksheets("Sheet2").Cells(1, 1) = "Randomiser results"
'now we populate sheet2 using the row numbers placed into the results array
For i = 1 To NbrItems
Worksheets("Sheet2").Cells(i + 1, 1) = Worksheets("Sheet1").Cells(Results(i), 1)
Next i
MsgBox ("Results on sheet 2!")
End Sub
Last edited: