Option Explicit
Sub TEST9()
Dim ar, br, i&, j&, r&, dic() As New Dictionary, iCount&, m&, n&
Application.ScreenUpdating = False
ar = [A1].CurrentRegion.Value
iCount = (UBound(ar) - 1) * UBound(ar, 2)
ReDim dic(1 To UBound(ar, 2))
For j = 1 To UBound(ar, 2)
For i = 2 To UBound(ar)
dic(j)(ar(i, j)) = dic(j)(ar(i, j)) + 1
Next i
n = n + dic(j).Count
Next j
Do Until n = iCount
For i = 2 To UBound(ar)
m = n
Do
br = Application.Index(ar, i)
arrGetRnd1 br
For j = 1 To UBound(ar, 2)
dic(j)(ar(i, j)) = dic(j)(ar(i, j)) - 1
If dic(j)(ar(i, j)) = 0 Then dic(j).Remove ar(i, j): n = n - 1
Next j
For j = 1 To UBound(ar, 2)
ar(i, j) = br(j)
If Not dic(j).Exists(ar(i, j)) Then n = n + 1
dic(j)(ar(i, j)) = dic(j)(ar(i, j)) + 1
Next j
Loop Until n >= m
If n = iCount Then Exit Do
Next i
Loop
[E1].Resize(UBound(ar), UBound(ar, 2)) = ar
Erase dic
Application.ScreenUpdating = True
Beep
End Sub
Function arrGetRnd1(ByRef ar)
Dim xNum&, i&, n&, vTemp
Randomize
n = UBound(ar)
For i = 1 To UBound(ar)
xNum = Int((n - i + 1) * Rnd() + i)
vTemp = ar(xNum): ar(xNum) = ar(i): ar(i) = vTemp
Next
End Function
|