Random Non Repeating Cell Selection - Filtered List

Dclarke

New Member
Joined
Sep 8, 2014
Messages
8
Hello,

I'm trying to create a database of trivia questions for work. The questions will be in one column, the answers will be in another, and a third column will contain category tags (Sports, Movies, etc.) The goal is for our trivia host to be able to open up this file, filter down to one category, and then have it randomly select 20 questions from that category. Obviously we don't want any duplicates in those 20 questions.

I found a code (below) that does reorganize a column into a random order without repeating, but it does not update if I filter down the list. It still pulls from the full, unfiltered list in the column.

Code:
Sub randomCollection()
    Dim Names As New Collection
    Dim lastRow As Long, i As Long, j As Long, lin As Long
    Dim wk As Worksheet
 
    Set wk = Sheets("Sheet1")
 
    With wk
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
 
    For i = 2 To lastRow
        Names.Add wk.Cells(i, 1).Value, CStr(wk.Cells(i, 1).Value)
    Next i
 
    lin = 1
    For i = lastRow - 1 To 1 Step -1
        j = Application.WorksheetFunction.RandBetween(1, i)
        lin = lin + 1
        Range("B" & lin) = Names(j)
        Names.Remove j
    Next i
 
End Sub

Granted, this code pulls the full list. So if there's 300 questions, it will just randomly reorder all 300. That would still be fine, as I could then just take the first 20, but if there was a way to limit it to only selecting 20, that would be great.I'm not sure if that code can be easily manipulated to perform what I am going for, but if it can, or if anyone has any other ideas on how to complete this task, all help would be greatly appreciated.

Thank you!
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

NeonRedSharpie

Well-known Member
Joined
Jul 14, 2014
Messages
1,678
Code:
Sub randomizeQuestions()

    Dim dBase As Worksheet
    Dim maxRow As Long
    Dim cnt As Long
    Dim category As String
    Dim counters As Long
    Dim catRng As Range
    Set dBase = Sheets(1)
    
    Application.ScreenUpdating = False
    With dBase
    
        maxRow = .Cells(Rows.Count, "C").End(xlUp).Row
    
        Set catRng = Range(Cells(1, 3), Cells(maxRow, 3))
        .Range(.Cells(1, 4), .Cells(1, 11)).EntireColumn.Clear
        
        category = InputBox("What category do you want?", "Select a category")
    
        For x = 1 To catRng.Rows.Count
            If .Cells(x, 3) = category Then .Cells(x, 4) = Application.WorksheetFunction.RandBetween(1, 1000)
        Next x
    
        .Cells(1, 6).EntireColumn.value = .Cells(1, 4).EntireColumn.value
    
        .Range(.Cells(1, 6), Cells(maxRow, 6)).Select
        Selection.SpecialCells(xlCellTypeBlanks).Select
        Selection.Delete Shift:=xlUp
        
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("F1"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
        
    With dBase.Sort
        .SetRange Range("F1:F" & dBase.Cells(Rows.Count, "F").End(xlUp).Row)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
    With dBase
        
        .Range(.Cells(1, 7), .Cells(20, 7)).FormulaR1C1 = _
            "=INDEX(C1:C4,MATCH(RC6,C4,0),1)"
        .Range(.Cells(1, 8), .Cells(20, 8)).FormulaR1C1 = _
            "=INDEX(C1:C4,MATCH(RC6,C4,0),2)"
        .Range(.Cells(21, 6), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, 6)).Clear
        
        .Cells(1, 1).Select
        
        .Range(.Cells(1, 4), .Cells(1, 6)).Clear


    End With


    Application.ScreenUpdating = True
End Sub


This was so much cleaner when I started writing and concepting this...but that's how it goes sometimes. This assumed your data is in A:C on sheet1. It then places 20 random questions and answers in G1:H20. It prompts with an inputbox for the category and takes longer than I like...but it gets the job done. Again...ugly...long...but gets there.
 

Dclarke

New Member
Joined
Sep 8, 2014
Messages
8
Thanks a lot Neon! It does seem to do the trick. A few minor things, and really not a huge deal at all, but just curious. I'm getting random numbers in Columns D and F, not sure what they are. Don't really affect much, so if they have to show up for it to work that's fine. Also, the first row set of Q/A in G1/H1 shows up as #N/A. 2 - 20 work perfectly, but with the first one showing an error, it's technically only 19 questions. Since I may have to change the number of questions in the future anyway, would you mind pointing out where in the code I would update this with the corresponding number?

Thanks again for your help, well done.
 

NeonRedSharpie

Well-known Member
Joined
Jul 14, 2014
Messages
1,678
D and F have random numbers because that's how I'm randomizing the dataset. They should be deleted after it runs though...you've discovered my secret!

Code:
[COLOR=#333333].Range(.Cells(1, 4), .Cells(1, 6)).Clear[/COLOR]

That should clear those values....but I messed up the code I just noticed. As for the number of questions, I'll add in another input box so it's easy to change. Someday I'll actually check my code before posting it. I always make last minute additions and just assume I didn't mess them up.

Code:
Sub randomizeQuestions()

    Dim dBase As Worksheet
    Dim maxRow As Long
    Dim cnt As Long
    Dim category As String
    Dim counters As Long
    Dim catRng As Range
    Dim qTot As Long
    
    Set dBase = Sheets(1)
    
    Application.ScreenUpdating = False
    With dBase
    
        maxRow = .Cells(Rows.Count, "C").End(xlUp).Row
    
        Set catRng = Range(Cells(1, 3), Cells(maxRow, 3))
        .Range(.Cells(1, 4), .Cells(1, 11)).EntireColumn.Clear
        
        category = InputBox("What category do you want?", "Select a category")
reask:
        qTot = InputBox("How many questions do you want to return?", "Input a number")
        
        If IsNumeric(qTot) Then Else GoTo reask:
        
        For x = 1 To catRng.Rows.Count
            If .Cells(x, 3) = category Then .Cells(x, 4) = Application.WorksheetFunction.RandBetween(1, 1000)
        Next x
    
        .Cells(1, 6).EntireColumn.value = .Cells(1, 4).EntireColumn.value
    
        .Range(.Cells(1, 6), Cells(maxRow, 6)).Select
        Selection.SpecialCells(xlCellTypeBlanks).Select
        Selection.Delete Shift:=xlUp
        
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("F1"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
        
    With dBase.Sort
        .SetRange Range("F1:F" & dBase.Cells(Rows.Count, "F").End(xlUp).Row)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
    With dBase
        
        .Range(.Cells(1, 7), .Cells(qTot, 7)).FormulaR1C1 = _
            "=INDEX(C1:C4,MATCH(RC6,C4,0),1)"
        .Range(.Cells(1, 8), .Cells(qTot, 8)).FormulaR1C1 = _
            "=INDEX(C1:C4,MATCH(RC6,C4,0),2)"
        .Range(.Cells(qTot + 1, 6), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, 6)).Clear
        
        With .Range(.Cells(1, 7), .Cells(qTot, 8))
            .value = .value
        End With
        
        
        .Cells(1, 1).Select
        
        .Range(.Cells(1, 4), .Cells(1, 6)).EntireColumn.Clear


    End With


    Application.ScreenUpdating = True
End Sub
 

Dclarke

New Member
Joined
Sep 8, 2014
Messages
8

ADVERTISEMENT

Wow, literally perfect. Thanks a ton!
 

L. Howard

Well-known Member
Joined
Oct 16, 2012
Messages
4,514
Hi Dclarke,

Hard to improve on perfect.

Here is a altered version of a bingo caller (hence the 75 item categories) to look at.

https://www.dropbox.com/s/1wki2w6fe...and Trivia Question System Drop Box.xlsm?dl=0

Pick a category in cell G2 and click the button "Next Question".

The data is to the right off screen, where "Movie-10" is a movie trivia question and "Answer Movie-10" is the answer. You replace with your real questions and answers.

When twenty questions have been asked you get a message box stating so.

Each category is a random "no Dupes questions" selection.

Start new game with the New Game button.

Regards,
Howard
 

Dclarke

New Member
Joined
Sep 8, 2014
Messages
8
Hello Howard,

Thank you for showing me this. It may prove useful, depending on how we decide to relay the questions. I think we may end up printing them out so our host can walk around, but if he is based at a computer, this may work very well.

Either way, thank you for the help.
 

L. Howard

Well-known Member
Joined
Oct 16, 2012
Messages
4,514
Okay, good, have fun.

And a 'lil nugget for your trivia:

What is the most easterly state that shares a Time Zone with Oregon?

That would be Florida. Florida's western panhandle and a single county in eastern Oregon both are in the same time zone briefly either going into or coming off of daylight savings time. I can't remember which. Of course verify what I say here first.

Regards,
Howard
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,652
Messages
5,838,603
Members
430,557
Latest member
MK15

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top