aşağıdaki kodu dener misiniz?
eğer değer girmezseniz sadece bir kelime bulur, ama diyelim ki 20 soruluk bir test için :
rastgeleTestCol 20 yazmanız yeterli

Sub rastgeleTestCol(Optional SoruSay As Long = 1)

Dim SonStr As Long

Dim Secim(0 To 3)



Set SozlukColl = New Collection

Set sht = ThisWorkbook.Sheets("VeriTabanı")

SonStr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

'hy____________________________Sözcükler için satır seçme

    For x = 2 To SonStr

             SozlukColl.Add x 'Collectiona değer atama

    Next x

AltSnr = 1

For Soru = 1 To SoruSay '

UstSnr = SozlukColl.Count

SonStr = Sayfa2.Cells(Sayfa2.Rows.Count, "A").End(xlUp).Row + 1

    For x = 0 To 3 'Rasgele 4 kelime için satır seçme

        UstSnr = SozlukColl.Count

        Randomize

        KelimSira = Int((UstSnr - AltSnr + 1) * Rnd + AltSnr)

        Secim(x) = KelimSira

        SozlukColl.Remove (KelimSira) 'seçilen satırı silme

    Next x

        Randomize

        Dogru = Int((3 - 0 + 1) * Rnd + 0) 'Esas kelimeyi seçme

        Sayfa2.Cells(SonStr, 1) = Soru

    For x = 0 To 3

        Sayfa2.Cells(SonStr, x + 3) = sht.Range("B" & SozlukColl(Secim(x))) 'Şıklar

    Next x

        Sayfa2.Cells(SonStr, 2) = sht.Range("A" & SozlukColl(Secim(Dogru))) 'Esas kelime

Next Soru



End Sub