Sub XYZ()
Dim sArr(), aNV, aStt, aVou, Res(), dic As Object, dem&
Dim eRow&, sRow&, sR&, sC&, i&, j&, jC&, k&, r, iR&, tmp
Set dic = CreateObject("scripting.dictionary")
With Sheets("Voucher code")
eRow = .Range("B" & Rows.Count).End(xlUp).Row
ReDim aVou(1 To Application.Sum(.Range("C2:C" & eRow)))
For i = 2 To eRow
For j = 1 To .Cells(i, "C").Value
sRow = sRow + 1
aVou(sRow) = .Cells(i, "B").Value
Next j
Next i
End With
With Sheet3
sR = .Range("A" & Rows.Count).End(xlUp).Row - 2
sC = .Cells(2, Columns.Count).End(xlToLeft).Column - 1
.Range("B3").Resize(sR, sC).ClearContents
End With
Trolai:
dem = dem + 1
If dem = 10000 Then Exit Sub
ReDim Res(1 To sR, 1 To sC)
k = sR
For j = 1 To sC
If j < 8 Then jC = 1 Else jC = j - 6
aStt = UniqueRand(sRow)
dic.RemoveAll
For i = 1 To sRow
If k < sR Then k = k + 1 Else k = 1: aNV = UniqueRand(sR)
If Res(aNV(k), j) <> Empty Then
For r = k + 1 To sR
If Res(aNV(r), j) = Empty Then
tmp = aNV(r)
aNV(r) = aNV(k): aNV(k) = tmp
End If
Next r
End If
iR = aNV(k)
tmp = aVou(aStt(i))
If NotExists(tmp, iR, Res, jC, j) Then
Res(iR, j) = tmp
dic.Add iR, ""
Else
For Each r In dic.keys
If NotExists(tmp, r, Res, jC, j) Then
If NotExists(Res(r, j), iR, Res, jC, j) Then
Res(iR, j) = Res(r, j)
Res(r, j) = tmp
Exit For
End If
End If
Next r
If Res(iR, j) = Empty Then
GoTo Trolai
End If
End If
Next i
Next j
Sheet3.Range("B3").Resize(sR, sC) = Res
MsgBox "Xong!"
End Sub
Private Function NotExists(ByVal tmp, ByVal i, Res, jC, j) As Boolean
Dim c&
For c = jC To j - 1
If Res(i, c) = tmp Then Exit For
Next c
If c = j Then NotExists = True
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
