Xếp lịch trực 1 năm
Mã:
Option Explicit
Sub LichTrucNam()
Application.ScreenUpdating = False
Range("B7:F372").ClearContents
Call CreateDate
Call LichNam
Application.ScreenUpdating = True
End Sub
Private Sub LichNam()
Dim aNV(), Arr, Res(), nam
Dim sRow&, N&, i&, k&, k2&, j&, j2&
Const Nu& = 9 'So NV Nu
With Sheets("Sheet1")
nam = .Range("C2").Value
aNV = .Range("N3:O78").Value
End With
sRow = UBound(aNV)
N = DateSerial(nam + 1, 1, 1) - DateSerial(nam, 1, 1)
ReDim Res(1 To N, 1 To 4)
Arr = UniqueRand(sRow, Nu)
For i = 1 To N
If k = sRow Then k = 1 Else k = k + 1
Res(i, 1) = Arr(k)
If k = sRow Then k = 1 Else k = k + 1
Res(i, 2) = Arr(k)
Next i
For i = 1 To N
k = Res(i, 1): k2 = Res(i, 2)
If aNV(k, 2) = "Nam" Then j = 3: j2 = 1 Else j = 1: j2 = 3
Res(i, j) = aNV(k, 1)
Res(i, j + 1) = aNV(k, 2)
Res(i, j2) = aNV(k2, 1)
Res(i, j2 + 1) = aNV(k2, 2)
Next i
Sheets("Sheet1").Range("C7").Resize(N, 4) = Res
End Sub
Private Sub CreateDate()
Dim aNgay(), fDay As Date, nam, i&
With Sheets("Sheet1")
nam = .Range("C2").Value
If Not IsNumeric(nam) Or nam = Empty Then nam = Year(Date): .Range("C2") = nam
fDay = DateSerial(nam, 1, 1)
ReDim aNgay(0 To 366, 1 To 1)
For i = 0 To 400
aNgay(i, 1) = fDay + i
If Year(fDay + i + 1) > nam Then Exit For
Next i
.Range("B7").Resize(i + 1) = aNgay
.Range("B7").Resize(i + 1).NumberFormat = "dd/mm/yyyy"
End With
End Sub
Function UniqueRand(ByVal sRow&, ByVal Nu&) As Variant
Dim Arr&(), tArr&(), N&, i&, RndNum&, tmp&, k&
ReDim Arr(1 To sRow): ReDim tArr(1 To sRow - Nu)
Randomize
For i = 1 To Nu
TroLai:
RndNum = Int((sRow - 2) * Rnd() + 2)
If (RndNum Mod 2) = 1 And Arr(RndNum) = 0 Then Arr(RndNum) = i Else GoTo TroLai
Next i
N = sRow - Nu
For i = 1 To N
RndNum = Int(N * Rnd() + 1)
If tArr(RndNum) = 0 Then tmp = RndNum Else tmp = tArr(RndNum)
If tArr(N) = 0 Then tArr(RndNum) = N Else tArr(RndNum) = tArr(N)
tArr(N) = tmp
N = N - 1
Next i
For i = 1 To sRow
If Arr(i) = 0 Then
k = k + 1
Arr(i) = tArr(k) + Nu
End If
Next i
UniqueRand = Arr
End Function
