bạn dùng code mới
Mã:
Sub Loc_Cot()
Dim Dic As Object, DicKQ As Object, tmp As String, Arr(), Sarr(), Darr(), Kq(), i As Integer, j As Integer, n As Integer
Dim C As Integer, k As Integer, dong As Integer, Dkq As Integer, jk As Integer, MinC As Integer, S As Integer, Lap As Integer
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
C = 100: MinC = 150
k = Sheets("DULIEU").UsedRange.Rows.Count - 1
Dkq = 30 'khai báo Dkq, so dòng ket qua theo ý
Lap = 350 'khai báo Lap, càng lon chay càng lau và ít bo sot ket qua
Sarr = Sheets("DULIEU").Range("A2", Sheets("DULIEU").Cells(k + 2, C)).Value
ReDim Darr(1 To UBound(Sarr), 1 To UBound(Sarr, 2))
ReDim Arr(1 To 2, 1 To C + 1): ReDim Kq(1 To Dkq, 1 To C + 1)
For j = 1 To C
Dic.RemoveAll: k = 0
For i = 1 To UBound(Sarr)
If Sarr(i, j) <> "" Then
If Not Dic.exists(Sarr(i, j)) Then
Dic.Add Sarr(i, j), ""
k = k + 1
Darr(k, j) = Sarr(i, j)
End If
Else
Arr(2, j) = k: 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: Dic.Add Darr(i, k), ""
Arr(1, C + 1) = 0: 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
Arr(1, j) = ""
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
Next jk
tmp = ""
For j = 1 To C
If Arr(1, j) = "" Then
tmp = tmp & "z" & "_"
Else
tmp = tmp & "z" & Arr(1, j)
End If
Next j
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
If MinC > Arr(1, C + 1) Then MinC = Arr(1, C + 1)
Else
If Arr(1, C + 1) > MinC Then
For n = 1 To Dkq
If Kq(n, C + 1) = MinC Then
For j = 1 To C + 1
Kq(n, j) = Arr(1, j)
Next j
Exit For
End If
Next n
MinC = 150
For n = 1 To Dkq
If MinC > Kq(n, C + 1) Then MinC = Kq(n, C + 1)
Next n
End If
End If
Tiep:
Next i
Next k
Darr = NgauNhien(Darr, Arr, C)
Next S
Sheets("KETQUA").Range("A2:CW2000").ClearContents
Sheets("KETQUA").Range("A2").Resize(Dkq, C + 1) = Kq
Set Dic = Nothing: Set DicKQ = Nothing
End Sub
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
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
