Sub Thuong()
Dim ShName As String, Loai As String, PhanThuong As String, LoaiPT As String
Dim Sh As Worksheet, sArr(), dArr(), tArr(), Arr, Arr2, Res()
Dim i&, r&, j&, sRow&, sRow2&, sCol&, K&, N&, ik&, m&, Q&, s&
With Sheets("PT")
i = .Range("B" & Rows.Count).End(xlUp).Row
If i < 7 Then MsgBox ("Khong co du lieu"): Exit Sub
sArr = .Range("A3:D" & i).Value
sRow2 = UBound(sArr)
i = .Range("E" & Rows.Count).End(xlUp).Row
If i < 4 Then MsgBox ("Khong co Loai phan thuong"): Exit Sub
dArr = .Range("E3:K" & i).Value
sRow = UBound(dArr): sCol = UBound(dArr, 2)
ShName = .Range("F3").Value
If ShName = "" Then MsgBox ("Ten Sheet Chua Khai Bao"): Exit Sub
PhanThuong = Mid(.Range("A3").Value, 1, Len(.Range("A3").Value) - 1) & " "
End With
Q = 0
For r = 2 To sRow
Q = Q + dArr(r, 2)
Next r
If Q = 0 Then MsgBox ("Khong co Loai phan thuong duoc chon"): Exit Sub
ReDim Res(1 To Q * 5, 1 To 3) 'Mang Ket Qua
For r = 2 To sRow
Loai = dArr(r, 1)
Q = dArr(r, 2)
If Len(Loai) > 0 And Q > 0 Then
For j = 3 To sCol
K = dArr(r, j)
If K > 0 Then '**
LoaiPT = dArr(1, j)
ReDim tArr(1 To 1)
Call Create_tArr(tArr, sArr, Loai, LoaiPT) 'Mang PT theo "Loai" va "LoaiPT"
If Len(tArr(1)) > 0 Then N = UBound(tArr) Else N = 0
If N >= K Then
Arr = Ngaunhien(N, K)
For i = 1 To K
ik = tArr(Arr(i))
Arr2 = Ngaunhien(4, 4) 'Tron Ket Qua A,B,C,D
For m = 0 To 4
s = s + 1
If m = 0 Then
stt = stt + 1
Res(s, 1) = stt
Res(s, 2) = PhanThuong & stt
Res(s, 3) = sArr(ik + m, 2)
Else
Res(s, 2) = sArr(ik + m, 1)
Res(s, 3) = sArr(ik + Arr2(m), 2)
End If
Next m
Next i
End If
End If '**
Next j
End If
Next r
For Each Sh In Worksheets 'Kiem tra Sheet Ket Qua
If Sh.Name = ShName Then i = 0: Exit For
Next
If i > 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = ShName
End If
With Sheets(ShName)
.UsedRange.ClearContents
i = .Range("B" & Rows.Count).End(xlUp).Row
If i > 2 Then Range("A3:C" & i).ClearContents
If s = 0 Then MsgBox ("Khong co Loai phan thuong duoc chon"): Exit Sub
.Range("A3").Resize(UBound(Res), UBound(Res, 2)) = Res
End With
Sheets(ShName).Select
End Sub
Private Sub Create_tArr(ByRef tArr, ByRef sArr, ByRef Loai, ByRef LoaiPT)
Dim i&, N&, sR&
sR = UBound(sArr)
For i = 1 To sR Step 5
If sArr(i, 3) = Loai And CStr(sArr(i, 4)) = LoaiPT Then
N = N + 1
ReDim Preserve tArr(1 To N)
tArr(N) = i
End If
Next i
End Sub
Private Function Ngaunhien(ByVal N&, ByVal K&)
Dim Arr() As Long, Res() As Long, i&, tmp&
If K > N Then K = N
ReDim Arr(1 To N): ReDim Res(1 To K)
Randomize
For i = 1 To K
tmp = Int((N * Rnd) + 1)
If Arr(tmp) = 0 Then Res(i) = tmp Else Res(i) = Arr(tmp)
If Arr(N) = 0 Then Arr(tmp) = N Else Arr(tmp) = Arr(N)
N = N - 1
Next i
Ngaunhien = Res
End Function
