Sub ThongKe()
Dim Darr(), Arr(), Ikey, Tmp, LastR As Long, S, i As Long, k As Long, j As Long
With Sheets("data")
LastR = .Range("B" & Rows.Count).End(xlUp).Row
If LastR < 4 Then Exit Sub
Darr = .Range("A4:G" & LastR).Value
End With
ReDim Arr(1 To UBound(Darr) * 2, 1 To 5)
With CreateObject("scripting.dictionary")
For i = 1 To UBound(Darr)
If Darr(i, 1) = "" Then Darr(i, 1) = Darr(i - 1, 1)
For j = 3 To 4
Tmp = Darr(i, j)
If Tmp <> "" Then
If Not .exists(Tmp) Then
.Add Tmp, "a" & "#" & i
Else
.Item(Tmp) = .Item(Tmp) & "#" & i
End If
End If
Next j
Next i
For Each Ikey In .keys()
k = k + 1: Arr(k, 1) = Ikey: k = k - 1
S = Split(.Item(Ikey), "#")
For j = 1 To UBound(S)
k = k + 1
Arr(k, 2) = Darr(S(j), 1)
Arr(k, 3) = Darr(S(j), 5)
Arr(k, 4) = Darr(S(j), 6)
Arr(k, 5) = Darr(S(j), 7)
Next j
Next
End With
With Sheets("ThongKe")
LastR = .Range("C" & Rows.Count).End(xlUp).Row
If LastR > 4 Then .Range("B5:F" & LastR).ClearContents
Darr = .Range("A4:G" & LastR).Value
.Range("B5:F5").Resize(k) = Arr
End With
End Sub
Sub LuuData()
Dim Darr(), iR As Long
With Sheets("PC")
Darr = .Range("D4:H" & .Range("D" & Rows.Count).End(xlUp).Row).Value
End With
With Sheets("data")
iR = .Range("B" & Rows.Count).End(xlUp).Row + 1
.Range("A" & iR) = Range("I3")
.Range("B" & iR) = 1
.Range("B" & iR).Resize(UBound(Darr)).DataSeries
.Range("C" & iR).Resize(UBound(Darr), 5) = Darr
End With
End Sub
Sub DoiGiamThi()
Dim Darr(), Sarr(), Arr(), Tmp
Dim i As Integer, j As Integer, k As Integer, N As Integer
Darr = Range("B4", Range("B" & Rows.Count).End(xlUp)).Value
Arr = Range("C4:E" & Range("C" & Rows.Count).End(xlUp).Row).Value
ReDim Sarr(1 To UBound(Darr))
With CreateObject("scripting.dictionary")
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
For j = 2 To 3
Tmp = Arr(i, j)
If Tmp <> "" Then
If Not .exists(Tmp) Then .Add Tmp, ""
End If
Next j
End If
Next i
For i = 1 To UBound(Darr)
Tmp = Darr(i, 1)
If Tmp <> "" Then
If Not .exists(Tmp) Then
k = k + 1
Sarr(k) = Tmp
End If
End If
Next i
If k = 0 Then MsgBox ("Khong tim thay CB co the phan cong"): Exit Sub
N = k
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
For j = 2 To 3
Tmp = Arr(i, j)
If Arr(i, j) = "" Then
Lap:
Tmp = Sarr(Int(Rnd() * k) + 1)
If Not .exists(Tmp) Then
.Add Tmp, ""
Arr(i, j) = Tmp
N = N - 1
If N = 0 Then GoTo Thoat
Else
GoTo Lap
End If
End If
Next j
End If
Next i
End With
Thoat:
Range("C4:E" & Range("C" & Rows.Count).End(xlUp).Row) = Arr
End Sub
Sub PhanCongGT()
Dim Rng As Range, Darr(), Sarr(), Arr(), LastR As Integer
Dim i As Integer, iR As Integer, j As Integer, k As Integer, N As Integer, M As Integer
Darr = Range("B4", Range("B" & Rows.Count).End(xlUp)).Value
LastR = Range("C" & Rows.Count).End(xlUp).Row
Set Rng = Range("C4:C" & LastR)
N = Rng.SpecialCells(xlCellTypeConstants).Count * 2
If N <= UBound(Darr) Then N = UBound(Darr)
Sarr = UniqueRandom(N)
ReDim Arr(1 To Rng.Count, 1 To 2)
For i = 1 To UBound(Arr)
If Rng(i, 1) <> "" Then
For j = 1 To 2
k = k + 1
iR = Sarr(k)
If iR <= UBound(Darr) Then
Arr(i, j) = Darr(iR, 1)
Else
Arr(i, j) = "???"
End If
Next j
End If
Next i
i = Range("D" & Rows.Count).End(xlUp).Row
If i > 4 Then Range("D4:E" & i).ClearContents
Range("D4:E" & LastR) = Arr
End Sub
Function UniqueRandom(ByVal N As Long) As Variant
Dim Arr As Variant, Darr As Variant, Tmp As Long, i As Long
ReDim Arr(1 To N): ReDim Darr(1 To N)
Randomize
For i = 1 To N
Tmp = Int(Rnd() * N) + 1
If Darr(Tmp) = 0 Then Darr(Tmp) = Tmp
Arr(i) = Darr(Tmp)
If Darr(N) = 0 Then Darr(Tmp) = N Else Darr(Tmp) = Darr(N)
N = N - 1
Next i
UniqueRandom = Arr
End Function
