Sub getWords()
    Dim sh1 As Worksheet, sh2 As Worksheet, dic As Object
    Dim lr&, iRnd%
    
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    Set dic = CreateObject("scripting.dictionary")
    With sh1
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 2 To lr
            iRnd = WorksheetFunction.RandBetween(2, 100)
            dic(Trim(.Cells(iRnd, 2))) = .Cells(iRnd, 3)
            If dic.Count = 25 Then Exit For
        Next i
    End With
    With sh2
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        .[b2].Resize(lr - 1, 3).ClearContents
        .[b2].Resize(dic.Count) = Application.Transpose(dic.keys)
        .[d2].Resize(dic.Count) = Application.Transpose(dic.items)
    End With
End Sub