Option Explicit
Sub LichTruc()
Dim aNV, aCH(), a, Res(), fDay As Date
Dim sCH&, sNV&, sd&, i&, k&, r&, j&
Const SoThang& = 1 'So tháng
sd = DateAdd("m", SoThang, fDay) - fDay 'So ngay trong Ky
ReDim Res(1 To sd, 1 To 5)
With Sheets("Sheet1")
fDay = .Range("C2").Value
aCH = .Range("J4:K7").Value
aNV = .Range("J8:K14").Value
End With
sCH = UBound(aCH): sNV = UBound(aNV)
aCH = UniqueRand(aCH, sCH) 'Tron ngau nhien Chi Huy
aNV = UniqueRand(aNV, sNV) 'Tron ngau nhien NV
Do
r = ((r + 2) Mod sNV) + 1
For j = 1 To sNV
i = i + 1
Res(i, 1) = fDay
If k = sCH Then k = 1 Else k = k + 1
Res(i, 2) = aCH(k)
If r = sNV Then r = 1 Else r = r + 1
Res(i, 3) = aNV(r)
If r = sNV Then r = 1 Else r = r + 1
Res(i, 4) = aNV(r)
Res(i, 5) = Format(fDay, "ddd")
fDay = fDay + 1
If i >= sd Then Exit Do
Next j
Loop
With Sheets("Sheet1")
.Range("B4:E400").Clear
.Range("B4").Resize(sd, 4) = Res
.Range("B4").Resize(sd, 4).Borders.LineStyle = 1
End With
End Sub
Function UniqueRand(ByVal arr, ByVal sRow&) As Variant
Dim a&(), t(), N&, i&, RndNum&, tmp&
N = sRow
ReDim a(1 To N)
ReDim t(1 To N)
For i = 1 To N
RndNum = Int(N * Rnd() + 1)
If a(RndNum) = 0 Then tmp = RndNum Else tmp = a(RndNum)
If a(N) = 0 Then a(RndNum) = N Else a(RndNum) = a(N)
a(N) = tmp
N = N - 1
Next i
For i = 1 To sRow
t(i) = arr(a(i), 1)
Next i
UniqueRand = t
End Function
