Random Non Repeating Cell Selection - Filtered List

[Dclarke]

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.

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!

 

[NeonRedSharpie]

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]

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]

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!

[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.

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]

Wow, literally perfect. Thanks a ton!

 

[L. Howard]

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

 

[L. Howard]

Hi Dclarke,

Here is a better version than the first one I posted, sorry for that.

Works about the same as the previous version, without the bugs I found in it.

Toss if not needed or wanted.


https://www.dropbox.com/s/u4cglqk3p... Phrases and Trivia Question System.xlsm?dl=0

Regards,
Howard

 

[Dclarke]

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]

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