Option Explicit
Dim a, S, sTran&, sVong&, sD&
Dim n&, i&, r&, k&, j&, j2&, c&, t&, z&, iKey$, iKey2$
Sub XYZ()
Dim sArr(), res(), dic As Object, sDoi&
Randomize
Set dic = CreateObject("scripting.dictionary")
With Sheets("Ten")
sArr = .Range("B4", .Range("B" & Rows.Count).End(xlUp)).Value
End With
sDoi = UBound(sArr)
Call XepLich(res, sArr, dic, sDoi)
n = UBound(res)
For j = 1 To sVong 'Gan ten cac doi
For i = 1 To sTran
S = Split(res(i, j), "_")
res(i, j) = sArr(CLng(S(0)), 1) & "_" & sArr(CLng(S(1)), 1)
Next i
If n > sTran Then res(n, j) = sArr(res(n, j), 1)
Next j
Sheets("Sheet1").Range("B4:X100").ClearContents
Sheets("Sheet1").Range("B4").Resize(n, sVong) = res
End Sub
Private Sub XepLich(res, sArr, dic, sDoi)
Dim bDoiLe As Boolean
bDoiLe = ((sDoi Mod 2) = 1)
If bDoiLe Then sVong = sDoi Else sVong = sDoi - 1 'So vong dau
sTran = sDoi \ 2 'So Tran 1 vong
sD = sTran * 2 'so Doi 1 vong
TuDau:
If bDoiLe = True Then
ReDim res(1 To sTran + 1, 1 To sVong)
a = UniqueRand(sVong)
For n = 1 To sVong
res(sTran + 1, n) = a(n)
Next n
Else
ReDim res(1 To sTran, 1 To sVong)
End If
For n = 1 To sVong
TroLai:
If bDoiLe = True Then
a = CreateUniqueRand(sDoi, res(sTran + 1, n))
Else
a = UniqueRand(sD)
End If
k = 0: i = 0
Do While k < sTran
i = i + 1
If a(i) <> Empty Then
k = k + 1
res(k, n) = a(i)
a(i) = Empty
For j = i + 1 To sD '***
If a(j) <> Empty Then
iKey = KeyValue(res(k, n), a(j))
If dic.exists(iKey) = False Then
dic.Add iKey, ""
res(k, n) = iKey
a(j) = Empty
Exit For
End If
End If
Next j
If j = sD + 1 Then '***
For r = 1 To k - 1
S = Split(res(r, n), "_")
For c = 0 To 1
iKey = KeyValue(res(k, n), S(c))
If dic.exists(iKey) = False Then
If c = 0 Then t = S(1) Else t = S(0)
For j2 = i + 1 To sD '***
If a(j2) <> Empty Then
iKey2 = KeyValue(t, a(j2))
If dic.exists(iKey2) = False Then
dic.Remove (res(r, n))
res(r, n) = iKey2: res(k, n) = iKey
dic.Add iKey, "": dic.Add iKey2, ""
a(j2) = Empty
GoTo Thoat
End If
End If
Next j2
End If
Next c
Next r
If r = k Then '****
z = z + 1
If z = 50 Then dic.RemoveAll: z = 0: GoTo TuDau
Call RemoveDic(res, dic)
GoTo TroLai
End If
End If
End If
Thoat:
Loop
Next n
End Sub
Private Sub RemoveDic(ByRef res, ByRef dic)
For r = 1 To k - 1
dic.Remove (res(r, n))
Next r
End Sub
Private Function KeyValue(ByVal val_1, ByVal val_2) As String
If CLng(val_1) < CLng(val_2) Then
KeyValue = val_1 & "_" & val_2
Else
KeyValue = val_2 & "_" & val_1
End If
End Function
Private Function CreateUniqueRand(ByVal n As Long, ByVal notNum) As Variant
Dim arr, res, i&, k&
arr = UniqueRand(n)
ReDim res(1 To n - 1)
For i = 1 To n
If arr(i) <> notNum Then
k = k + 1
res(k) = arr(i)
End If
Next i
CreateUniqueRand = res
End Function
Private Function UniqueRand(ByVal n As Long) As Variant
Dim arr() As Long, i&, RndNum&, tmp&
ReDim arr(1 To n)
'Randomize
For i = 1 To n
RndNum = Int(n * Rnd() + 1)
If arr(RndNum) = 0 Then tmp = RndNum Else tmp = arr(RndNum)
If arr(n) = 0 Then arr(RndNum) = n Else arr(RndNum) = arr(n)
arr(n) = tmp
n = n - 1
Next i
UniqueRand = arr
End Function
) => Lúc đó bạn cần tới 500.000.000 giây để nhập hết
