Dim Dkq As Integer, Lap As Byte
Sub Main()
Dim Darr(), kq1(), kq2(), kq3(), kq4(), kq5(), Skq(), tmp As String
Dim Dic2 As Object, Dic3 As Object, Dic4 As Object, Dic5 As Object
Dim Sr As Integer, i As Integer, k As Integer, C As Byte, n As Byte, j As Byte
Set Dic = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")
Set Dic3 = CreateObject("scripting.dictionary")
Set Dic4 = CreateObject("scripting.dictionary")
Set Dic5 = CreateObject("scripting.dictionary")
C = 80
Dkq = 1000 'khai báo Dkq, so dòng ket qua theo ý
Lap = 10 'khai báo Lap, càng lon chay càng lau và ít bo sot ket qua
Sr = Sheets("DULIEU").UsedRange.Rows.Count
ReDim Skq(1 To 1, 1 To C)
For n = 1 To 5
Darr = Sheets("DULIEU").Cells(2, (n - 1) * C + 1).Resize(Sr, C).Value
If n = 1 Then
kq1 = LocCot(Darr(), C)
Sheets("Sheet1").Cells(2, (n - 1) * C + 1).Resize(Dkq, C) = kq1
ElseIf n = 2 Then
kq2 = LocCot(Darr(), C)
For i = 1 To Dkq
For j = 1 To C
Skq(1, j) = Format(kq2(i, j), "00")
Next j
tmp = SortArrToStr(Skq, "z")
Dic2.Add tmp, i
Next i
Sheets("Sheet1").Cells(2, (n - 1) * C + 1).Resize(Dkq, C) = kq2
ElseIf n = 3 Then
kq3 = LocCot(Darr(), C)
For i = 1 To Dkq
For j = 1 To C
Skq(1, j) = Format(kq3(i, j), "00")
Next j
tmp = SortArrToStr(Skq, "z")
Dic3.Add tmp, i
Next i
Sheets("Sheet1").Cells(2, (n - 1) * C + 1).Resize(Dkq, C) = kq3
ElseIf n = 4 Then
kq4 = LocCot(Darr(), C)
For i = 1 To Dkq
For j = 1 To C
Skq(1, j) = Format(kq4(i, j), "00")
Next j
tmp = SortArrToStr(Skq, "z")
Dic4.Add tmp, i
Next i
Sheets("Sheet1").Cells(2, (n - 1) * C + 1).Resize(Dkq, C) = kq4
Else
kq5 = LocCot(Darr(), C)
For i = 1 To Dkq
For j = 1 To C
Skq(1, j) = Format(kq5(i, j), "00")
Next j
tmp = SortArrToStr(Skq, "z")
Dic5.Add tmp, i
Next i
Sheets("Sheet1").Cells(2, (n - 1) * C + 1).Resize(Dkq, C) = kq5
End If
Next n
ReDim Darr(1 To Dkq, 1 To C * 5)
k = 0
For i = 1 To Dkq
For j = 1 To C
Skq(1, j) = Format(kq1(i, j), "00")
Next j
tmp = SortArrToStr(Skq, "z")
If Dic2.exists(tmp) Or Dic3.exists(tmp) Or Dic4.exists(tmp) Or Dic5.exists(tmp) Then
k = k + 1
For j = 1 To C
Darr(k, j) = kq1(i, j)
If Dic2.exists(tmp) Then Darr(k, j + 80 * 1) = kq2(Dic2.Item(tmp), j)
If Dic3.exists(tmp) Then Darr(k, j + 80 * 2) = kq3(Dic3.Item(tmp), j)
If Dic4.exists(tmp) Then Darr(k, j + 80 * 3) = kq4(Dic4.Item(tmp), j)
If Dic5.exists(tmp) Then Darr(k, j + 80 * 4) = kq5(Dic5.Item(tmp), j)
Next j
End If
Next i
Set Dic = Nothing: Set Dic2 = Nothing: Set Dic3 = Nothing: Set Dic4 = Nothing: Set Dic5 = Nothing
Sheets("KETQUA").Range("A2").Resize(2000, 400).ClearContents
If k > 0 Then Sheets("KETQUA").Range("A2").Resize(k, 400) = Darr
End Sub
Function LocCot(Darr(), C As Byte)
Dim Dic As Object, DicKQ As Object, tmp As String, Arr(), Kq(), i As Integer, j As Integer, n As Integer
Dim k As Integer, dong As Long, jk As Integer, MinC As Integer, S As Byte
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
ReDim Arr(1 To 2, 1 To C + 1): ReDim Kq(1 To Dkq, 1 To C + 1)
For j = 1 To C
For i = 1 To UBound(Darr) + 1
If Darr(i, j) = "" Then
Arr(2, j) = i - 1: Exit For
End If
Next i
Next j
For S = 1 To Lap
For k = 1 To C
For i = 1 To Arr(2, k)
Dic.RemoveAll: Arr(1, C + 1) = 0
Dic.Add Darr(i, k), ""
Arr(1, k) = Darr(i, k)
Arr(1, C + 1) = Arr(1, C + 1) + 1
For jk = 2 To C
j = jk: If jk = k Then j = 1
For n = 1 To Arr(2, j)
If Not Dic.exists(Darr(n, j)) Then
Dic.Add Darr(n, j), ""
Arr(1, j) = Darr(n, j)
Arr(1, C + 1) = Arr(1, C + 1) + 1
Exit For
End If
Next n
If Arr(1, C + 1) < jk Then GoTo Tiep
Next jk
tmp = SortArrToStr(Arr, "z")
If Not DicKQ.exists(tmp) Then
DicKQ.Add tmp, ""
Else
GoTo Tiep
End If
If dong < Dkq Then
dong = dong + 1
For j = 1 To C + 1
Kq(dong, j) = Arr(1, j)
Next j
Else
GoTo Thoat
End If
Tiep:
Next i
Next k
Darr = NgauNhien(Darr, Arr, C)
Next S
Thoat:
LocCot = Kq
Erase Arr: Erase Kq
Set Dic = Nothing: Set DicKQ = Nothing
End Function
Public Function SortArrToStr(Arr As Variant, Str As String) As String
Dim ArrList As Object, Darr As Variant, j As Byte, tmp As String
Set ArrList = CreateObject("System.Collections.ArrayList")
For j = LBound(Arr, 2) To UBound(Arr, 2)
tmp = Arr(1, j): ArrList.Add tmp
Next
ArrList.Sort
Darr = ArrList.ToArray
SortArrToStr = Join(Darr, Str)
Set ArrList = Nothing: Erase Darr
End Function
Function NgauNhien(Darr(), Arr(), C)
Dim Dic As Object, tmp As Integer, Sarr(), i As Integer, j As Integer, k As Integer
Set Dic = CreateObject("scripting.dictionary")
ReDim Sarr(1 To UBound(Darr), 1 To UBound(Darr, 2))
For j = 1 To C
For i = 1 To k + 1
If Darr(i, j) = "" Then
Arr(2, j) = i - 1: Exit For
End If
Next i
Next j
For j = 1 To C
Dic.RemoveAll: k = 0
Do
tmp = Int((Arr(2, j) * Rnd) + 1)
If Not Dic.exists(tmp) Then
k = k + 1: Dic.Add tmp, ""
Sarr(k, j) = Darr(tmp, j)
End If
Loop Until k = Arr(2, j)
Next j
NgauNhien = Sarr
Set Dic = Nothing
End Function
