Option Explicit
Sub XYZ()
Dim sArr(), ToHop, NNhien, Res(), fRow&, eRow&
Dim N&, sRow&, v&, i&, r&, k&, c&, iR&, tmp$, Sott$
fRow = 3 'Dong dau
eRow = Range("B" & Rows.Count).End(xlUp).Row
If eRow < fRow Then Exit Sub
sArr = Range("M3:M8").Value: N = UBound(sArr)
ToHop = Tohop_N_Chap_K(N, 2): sRow = UBound(ToHop)
For v = fRow To eRow Step sRow
ReDim Res(1 To sRow, 1 To 8)
NNhien = UniqueRand(sRow)
For i = 1 To sRow 'Ket qua cot 1 va 2
iR = NNhien(i, 1)
Res(i, 1) = ToHop(iR, 1)
Res(i, 2) = ToHop(iR, 2)
Res(i, 7) = ToHop(iR, 1) & ToHop(iR, 2)
Next i
TroLai:
NNhien = UniqueRand(sRow)
For i = 1 To sRow 'Ket qua cot 3 va 4
tmp = Res(i, 7)
For r = 1 To sRow
iR = NNhien(r, 1)
If iR > 0 Then
If InStr(1, tmp, ToHop(iR, 1)) = 0 Then
If InStr(1, tmp, ToHop(iR, 2)) = 0 Then
Sott = ChuoiThuTu(N, ToHop(iR, 1) & ToHop(iR, 2) & tmp)
For k = 1 To i - 1
If Res(k, 8) = Sott Then Exit For
Next k
If k = i Then
Res(i, 3) = ToHop(iR, 1)
Res(i, 4) = ToHop(iR, 2)
Res(i, 8) = Sott
NNhien(r, 1) = 0
Exit For
End If
End If
End If
End If
Next r
If r = sRow + 1 Then GoTo TroLai
Next i
For i = 1 To sRow 'Ket qua cot 5 va 6
tmp = Res(i, 8)
c = 4
For r = 1 To N
If InStr(1, tmp, CStr(r)) = 0 Then
c = c + 1
Res(i, c) = r
End If
Next r
Next i
For i = 1 To sRow 'Gan ten Nhan vien
For c = 1 To N
Res(i, c) = sArr(Res(i, c), 1)
Next c
Next i
Range("C" & v).Resize(sRow, 6) = Res ' gan ket qua 1 chu ky sRow dong
Next v
End Sub
Private Function ChuoiThuTu(N, ByVal ThuTu) As String
Dim Arr(), Res$, i&
ReDim Arr(1 To N)
For i = 1 To Len(ThuTu)
Arr(Mid(ThuTu, i, 1)) = 1
Next i
For i = 1 To N
If Arr(i) = 1 Then Res = Res & i
Next i
ChuoiThuTu = Res
End Function
Private Function Tohop_N_Chap_K(ByVal N&, ByVal k&) As Variant
'Mang To hop N chap K, bieu dien bang chuoi các ký tu "0" va "1"
'Thu tu gia tri "1" là thu tu du lieu nguon lay du lieu
Dim Arr$(), Res&(), tmp$, j&, p&, s&, sRow&, c&
sRow = Application.Combin(N, k)
ReDim Arr(1 To sRow, 1 To 1)
tmp = String(k, "1") & String(N - k, "0")
p = 1: Arr(p, 1) = tmp
Do
j = InStrRev(tmp, "1")
Mid(tmp, j, 1) = "0"
Mid(tmp, j + 1, s + 1) = String(s + 1, "1")
s = 0: p = p + 1: Arr(p, 1) = tmp
If InStr(j + 1, tmp, "0") = 0 Then
s = N - j
Mid(tmp, j + 1, s) = String(s, "0")
End If
Loop Until s = k
ReDim Res(1 To sRow, 1 To k)
For s = 1 To sRow
c = 0
tmp = Arr(s, 1)
For j = 1 To N
If Mid(tmp, j, 1) = "1" Then c = c + 1: Res(s, c) = CStr(j)
Next j
Next s
Tohop_N_Chap_K = Res
End Function
Function UniqueRand(ByVal N As Long) As Variant
'UniqueRand: mang ngau nhien cac so khong trung tu 1 -> N
Dim Arr() As Long, i&, RndNum&, tmp&
ReDim Arr(1 To N, 1 To 1)
Randomize
For i = 1 To N
RndNum = Int(N * Rnd() + 1)
If Arr(RndNum, 1) = 0 Then tmp = RndNum Else tmp = Arr(RndNum, 1)
If Arr(N, 1) = 0 Then Arr(RndNum, 1) = N Else Arr(RndNum, 1) = Arr(N, 1)
Arr(N, 1) = tmp
N = N - 1
Next i
UniqueRand = Arr
End Function