Sub quiz()
    Dim rng     As Range 'диапазон "базы данных"
    Dim rCnt    As Integer
    Dim n       As Integer
    Dim m       As Integer
    Dim dictN   As Object 'Scripting.Dictionary
    Dim dictM   As Object 'Scripting.Dictionary
    Dim dictM2  As Object 'Scripting.Dictionary
    Dim curr    As Integer
    Dim arrNM() As Integer 'результирующий массив данных викторины
    Dim i       As Integer
    Dim j       As Integer
    Dim itemsN  As Variant
    Dim itemsM  As Variant
    Dim itemsM2 As Variant
    
    n = 10 'кол-во вопросов викторины
    m = 4 'кол-во ответов в одном вопросе
    
    Set rng = Worksheets("Entertainment").Range("A2:B" & Worksheets("Entertainment").Cells(Rows.Count, 1).End(xlUp).Row)
    
    rCnt = rng.Rows.Count 'кол-во строк в "базе данных"
    
    If n > rCnt Then n = rCnt
    If m > rCnt Then m = rCnt
    
    'случайный выбор "вопросов" - номеров строк в БД
    Set dictN = CreateObject("Scripting.Dictionary")
    Do
        curr = WorksheetFunction.RandBetween(1, rCnt)
        On Error Resume Next
            dictN.Add curr, curr
        On Error GoTo 0
    Loop Until dictN.Count = n
    
    ReDim arrNM(1 To n, 1 To m + 2)
    
    Set dictM = CreateObject("Scripting.Dictionary")
    Set dictM2 = CreateObject("Scripting.Dictionary")
    'генерирование "ответов" на ранее выбранные "вопросы": один правильный, остальные неправильные
    itemsN = dictN.items
    For i = 1 To n
        arrNM(i, 1) = itemsN(i - 1)
        dictM.RemoveAll
        
        'добавление одного правильного "ответа"
        curr = arrNM(i, 1)
        dictM.Add curr, curr
        
        'случайный выбор неправильных "ответов"
        Do
            curr = WorksheetFunction.RandBetween(1, rCnt)
            On Error Resume Next
                dictM.Add curr, curr
            On Error GoTo 0
        Loop Until dictM.Count = m
        
        'перемешивание "ответов" для текущего "вопроса"
        itemsM = dictM.items
        dictM2.RemoveAll
        Do
            j = WorksheetFunction.RandBetween(1, m)
            On Error Resume Next
                dictM2.Add j, itemsM(j - 1)
            On Error GoTo 0
        Loop Until dictM2.Count = m
        
        'определение номера правильного "ответа" и прописывание в массив
        itemsM2 = dictM2.items
        For j = 1 To m
            curr = itemsM2(j - 1)
            arrNM(i, j + 1) = curr
            If curr = itemsM(0) Then
                arrNM(i, m + 2) = j 'номер правильного "ответа"
            End If
        Next j
        
    Next i
    Set dictM2 = Nothing
    Set dictM = Nothing
    Set dictN = Nothing
    
    'как-то визуализируем рассчитанное
    With Worksheets("ДанныеВикторины").Range("A2:F1000")
        .ClearContents
        .Resize(n, m + 2) = arrNM
    End With
    
End Sub