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!
 

Some videos you may like

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

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
 

Watch MrExcel Video

Forum statistics

Threads
1,109,428
Messages
5,528,698
Members
409,830
Latest member
KT50

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
  • VBA COUNTIF SOLUTION
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
  • INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...
Top