Help pulling random sample, please?

[tjroby]

I'm having trouble with random sampling again. I've created an example spreadsheet to test this with in a way that I can easily see if I am getting duplicates or not. I'm getting duplicates!

Here's the code:

Option Explicit
Sub Random_Test()
    Dim i       As Long
    Dim ii       As Long
    Dim nItem   As Long
    Dim iItem   As Long
    Dim vRnd    As Variant
    Dim rList   As Range
    Dim rSamp   As Range
    Dim shArr
    
    shArr = Array("BFTE", "CFTE")
    With Sheets.Add
        .Name = "To Survey"
        .Range("A1").FormulaR1C1 = "BFTE bud ID"
        .Range("C1").FormulaR1C1 = "CFTE bud ID"
    End With
       
    ii = 1
    For i = 0 To UBound(shArr)
        With Worksheets(shArr(i))
            nItem = (Application.WorksheetFunction.CountA(.Range("D4", .Range("D65536").End(xlUp)))) * 0.1
            Set rList = .Range("E4").CurrentRegion
        End With
        With Worksheets("To Survey")
            Set rSamp = .Cells(Rows.Count, ii).End(xlUp).Offset(1, 0).Resize(nItem)
            vRnd = RandBetw(1, rList.Rows.Count)
            For iItem = 1 To nItem
                rSamp(iItem, 1) = iItem
                rSamp(iItem, 1) = rList(vRnd(iItem), 5)
            Next iItem
        End With
    ii = ii + 2
    Next
    
    Sheets("To Survey").Columns("A:C").EntireColumn.AutoFit
    
End Sub

Please help!

 

[tjroby]

Still can't figure this one out. Please help if you can.