Sub primer()
    Set sh1 = ThisWorkbook.Sheets(1)
    With sh1
        lr = .Cells(.Rows.Count, 2).End(xlUp).Row
        Randomize
        indWord = Int((lr - 1) * Rnd + 2)
        'выбираем слово для перевода из столбца С
        Sheets(2).Range("d4") = .Cells(indWord, "c")
        cat = .Cells(indWord, 4)
        With CreateObject("Scripting.Dictionary")
            Do
                r = Int((lr - 1) * Rnd + 2)
                If sh1.Cells(r, 4) = cat Then
                    .Item(r) = .Item(r) + 1
                End If
            Loop While .Count < 5
            Arr = .keys
            For i = 0 To .Count - 1
                'варианты перевода из столбца B
                Cells(6 + i, 4) = sh1.Cells(Arr(i), "b")
            Next
        End With
    End With
End Sub

Dim arrAll(), arrI()
Dim rng1 As Range
Const LBNAME As String = "basa"
Const LTNAME As String = "Лист1"

Public Sub setData()
Dim numRow As Long
Dim i As Long, j As Long, k As Long
Dim maxN As Integer

With Worksheets(LBNAME)
.Activate
numRow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng1 = Worksheets(LBNAME).Range("A1", Cells(numRow, 4))
End With
For i = 2 To rng1.Rows.Count
    If maxN < rng1.Cells(i, 4) Then maxN = rng1.Cells(i, 4)
Next i
ReDim arrAll(1 To maxN)
For j = 1 To maxN
    k = 0
    ReDim arrI(1 To numRow)
    For i = 2 To numRow
        If rng1.Cells(i, 4) = j Then
            k = k + 1
            arrI(k) = i
        End If
    Next i
    ReDim Preserve arrI(1 To k)
    arrAll(j) = arrI
Next j
End Sub

Public Sub chooseWrd()
Dim arrNum As Integer
Dim i As Integer, j As Integer
Dim k As Long, l As Long, buff As Long

If (Not arrAll) = -1 Then 'существует ли массив
    Call setData
End If
arrNum = UBound(arrAll)
Randomize
i = Int((arrNum * Rnd) + 1)
l = UBound(arrAll(i))
For j = 1 To l
    k = Int((l * Rnd) + 1)
    buff = arrAll(i)(j)
    arrAll(i)(j) = arrAll(i)(k)
    arrAll(i)(k) = buff
Next j
With Worksheets(LTNAME)
.Activate
For j = 1 To 5
  .Cells(5 + j, 4).Value = rng1.Cells(arrAll(i)(j), 2)
Next j
j = Int((5 * Rnd) + 1)
.Cells(4, 4).Value = rng1.Cells(arrAll(i)(j), 3)
End With
End Sub