Sub PickAtRandom()
Dim i As Integer, intRank As Integer

Randomize
Range("B2").Select

For i = 8 To 14
  ActiveCell.Offset(i, 0).Value = _
  ActiveCell.Offset(i - 8, 0).Value
  ActiveCell.Offset(i - 8, 2).Value = Rnd
Next i

For i = 8 To 14
intRank = Application.WorksheetFunction.Rank _
(ActiveCell.Offset(i - 8, 2).Value, _
Range("D2:D8"))
ActiveCell.Offset(i, 1).Value = _
ActiveCell.Offset(intRank - 1, 1).Value
Next i

End Sub