Select random cell from Sheet1 range and copy to Sheet2

[Human_doing]

Hi all,

Can anyone please provide any help with VBA code to help with this:

I am looking to be able to open a workbook (which will have a range of cells in column A with data, but this range will be different each time), and then have Excel automatically highlight from cell A2 (with A1 being the header) to the last cell with data in column A. Also have a message box pop up that asks how many cells are to be selected.

When the user selects 'Ok' in the message box, if for example the user has selected 3 cells, then 3 random cells are selected from the range and copied to sheet2 column A, with no duplicates,

Any help much appreciated,

Thanks

 

[ChrisOswald]

This is definitely not the most efficient way of doing this (triple nested loop?!?), but it should work. Code assumes your input sheet is named "Sheet1". It also clears out everything in Column A of "Sheet2"

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("Please enter the number of items you want to have sampled")
    If Not IsNumeric(NbrItems) Then
        MsgBox ("Not a number")
        Exit Sub
    ElseIf Int(CDbl(NbrItems)) <> CDbl(NbrItems) Then
        MsgBox ("Not an integer")
        Exit Sub
    ElseIf CDbl(NbrItems) <= 0 Then
        MsgBox ("Must be a positive integer")
        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 items 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) = "Sample items"
    '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
End Sub

 

[Human_doing]

Hi, thanks that is really great code and it does work perfectly. Could you please tell me how to add column B to the selection i.e. A & B rather than just A?

Thanks

 

[ChrisOswald]

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("Please enter the number of items you want to have sampled")
    If Not IsNumeric(NbrItems) Then
        MsgBox ("Not a number")
        Exit Sub
    ElseIf Int(CDbl(NbrItems)) <> CDbl(NbrItems) Then
        MsgBox ("Not an integer")
        Exit Sub
    ElseIf CDbl(NbrItems) <= 0 Then
        MsgBox ("Must be a positive integer")
        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 items 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").Columns(2).Clear
    Worksheets("Sheet2").Cells(1, 1) = "Sample items"
    Worksheets("Sheet2").Cells(1, 2) = "Other Sample Item value"
    '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)
        Worksheets("Sheet2").Cells(i + 1, 2) = Worksheets("Sheet2").Cells(Results(i), 2)
    Next i
End Sub

This will work to pull both items. Word of warning, this will be pretty slow (I haven't tested it to see how slow) if you're pulling a large sample from a large data set. A better way to do this would be to (code idea to play around with, I'm going to be busy for the next few days)

1) create a new worksheet.
2) copy columns A and B onto the new worksheet
3) add a random number to column c for each item.
4) sort ascending on c (using vba)
5) delete everything after the (N+1) row, where N is the number of items you want in your sample

I should have answered using the above idea on Friday, but I was pretty brain-fried and was using Mr Excel to try to break out of an "infinite thought loop."

 

[Human_doing]

Thanks for that great answer it works perfectly.

Thanks