Random select names from a list (w/some duplicates) to a new list without duplicates

Sub Random_Names()
Dim NameColumn As Integer
Dim FirstNameRow As Integer
Dim NewColumn As Integer
Dim NumberOfNames As Integer
Dim lrow As Long
Dim StoredNames As String
Dim Counter As Integer
Dim Name As String


NameColumn = 1 'Change this if your names are not in column A
FirstNameRow = 2 'Change this if your first name does not start in row 2 (1 would be the column header)
NewColumn = 5 'Change this if you want to change the column of 10 names from column E to a different colulmn
NumberOfNames = 10 '10 Names in new list


lrow = Cells(Rows.Count, NameColumn).End(xlUp).Row
Counter = 2
StoredNames = ""


Cells(1, NewColumn) = "Random Name List (" & NumberOfNames & ")"
Range(Cells(2, NewColumn), Cells(NumberOfNames + 1, NewColumn)).ClearContents


Do Until Cells(NumberOfNames + 1, NewColumn) <> ""
    Name = WorksheetFunction.Index(Range(Cells(FirstNameRow, NameColumn), Cells(lrow, NameColumn)), WorksheetFunction.RandBetween(1, lrow - FirstNameRow + 1))
    If InStr(StoredNames, Name) = 0 Then
        StoredNames = StoredNames & " " & Name
        Cells(Counter, NewColumn) = Name
        Counter = Counter + 1
    End If
Loop




End Sub