การสุ่มข้อมูลที่ไม่ซ้ำกันเป็นชุด ๆ (VBA)

Option Explicit
 
Sub TestUnique()
    Dim a() As Variant, b() As Variant
    Dim i As Integer, j As Integer
    Dim k As Integer, l As Integer
    l = 4 'Random 1-4
    For i = 1 To l
        ReDim Preserve a(i)
        a(i) = i
    Next i
    For i = 1 To l
        ReDim Preserve b(i)
        Do
            j = a(Int(Rnd() * l + 1))
            On Error Resume Next
            k = Application.Match(j, b, 0)
        Loop Until Err = 13
        On Error GoTo 0
        b(i) = j
    Next i
    For i = 1 To l
        If Selection.Cells(i, 1).Offset(0, -1) = "" Then Exit For
        Selection.Cells(i, 1) = b(i)
    Next i
End Sub
 
Sub RandomUnique()
    Do
        TestUnique
        Selection.Cells(500, 1).End(xlUp).Offset(1, 0).Activate
    Loop Until Selection.Offset(0, -1) = ""
End Sub