Option Explicit
Sub XYZ()
Dim dic As Object, dic2 As Object, dKH As Object, dDH As Object, dSP As Object
Dim aTH$(), sTH&, sCol&, iMin&
Dim arr(), res(), aDH, aSP, a, b()
Dim dh$, sp$, kh, tmp$
Dim sRow&, sDH&, sDon#, k&, N&, i&, j&, r&, c&, id&, jd&
iMin = -1 'Dieu kien xet cot So luong: So luong >= 0 (iMin = -1), So luong >0 (iMin = 0)
sCol = 10 'Thong thuong: 10 < sCol < 20
Call Creat_TH(aTH, sTH, sCol)
Set dic = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set dKH = CreateObject("scripting.dictionary")
Set dDH = CreateObject("scripting.dictionary")
Set dSP = CreateObject("scripting.dictionary")
arr = Range("A2", Range("D" & Rows.Count).End(xlUp)).Value
sRow = UBound(arr)
ReDim res(1 To sRow, 1 To 5)
For i = 1 To sRow
If arr(i, 3) > iMin Then
kh = arr(i, 1)
dh = kh & "|" & arr(i, 4)
sp = dh & "|" & arr(i, 2)
If dSP.exists(sp) = False Then
dSP.Add sp, ""
If dDH.exists(dh) = False Then
dDH.Add dh, Array(arr(i, 2))
If dKH.exists(kh) = False Then
dKH(kh) = Array(dh)
Else
a = dKH(kh) 'Gan DH moi vao Khach hang
ReDim Preserve a(0 To UBound(a) + 1)
a(UBound(a)) = dh
dKH(kh) = a
End If
Else
a = dDH(dh) 'gán San Pham vào Don hang
ReDim Preserve a(0 To UBound(a) + 1)
a(UBound(a)) = arr(i, 2)
dDH(dh) = a
End If
End If
End If
Next i
For Each kh In dKH.keys
aDH = dKH(kh)
sDH = UBound(aDH) 'So Don Hang
sDon = (sDH + 1) * 0.75 '75% So Don hang
dic.RemoveAll: dic2.RemoveAll
k = 0
For i = 0 To sDH
aSP = dDH(aDH(i))
For j = 0 To UBound(aSP)
sp = aSP(j)
N = dic(sp) + 1
dic(sp) = N
If N > sDon Then
If dic2.exists(sp) = False Then
k = k + 1
dic2.Add sp, k
ReDim Preserve a(1 To k)
a(k) = sp
For c = 0 To sDH
If dSP.exists(aDH(c) & "|" & sp) Then dic2(c & "|" & sp) = ""
Next c
End If
End If
Next j
Next i
If k > 1 Then
If k > sCol Then sCol = k: Call Creat_TH(aTH, sTH, sCol) 'Tao lai TH Lon hon
For i = 1 To sTH
N = aTH(i, 2): If N > k Then Exit For
tmp = aTH(i, 1)
jd = 0: id = 0
For j = 1 To N
If Mid(tmp, j, 1) = "1" Then
jd = jd + 1
ReDim Preserve b(1 To jd)
b(jd) = a(j)
End If
Next j
For c = 0 To sDH
For j = 1 To jd
If dic2.exists(c & "|" & b(j)) = False Then Exit For
Next j
If j = jd + 1 Then id = id + 1 'Dem so don hang cua San pham
Next c
If id > sDon Then
r = r + 1
res(r, 1) = kh
res(r, 2) = sDH + 1
res(r, 3) = sDon
res(r, 4) = id
res(r, 5) = Join(b, ", ")
End If
Next i
End If
Next kh
If Range("H6").Value <> Empty Then Range("H6").CurrentRegion.ClearContents
If r Then Range("H6").Resize(r, 5) = res 'Sp mua cung nhau
End Sub
Sub Creat_TH(aTH, sTH, sCol)
Dim N&, i&, j&, S&, r&, tmp$
ReDim bTH(2 To sCol, 1 To 1)
j = 2
N = 2 ^ sCol - 1
ReDim aTH(1 To N - 2, 1 To 2)
For i = 3 To N
tmp = D2B(i, sCol)
If tmp <> Empty Then
r = r + 1
aTH(r, 1) = StrReverse(tmp)
aTH(r, 2) = j
End If
If i >= S Then
j = j + 1
S = 2 ^ j
End If
Next i
sTH = r
End Sub
Function D2B(num, sCol) As String
Dim qt&, rd&, tmp$, L&
qt = num
Do
rd = qt Mod 2
If rd = 1 Then L = L + 1
qt = Int(qt / 2)
tmp = rd & tmp
Loop Until qt = 0
If L > 1 Then D2B = Format(Val(tmp), String(sCol, "0"))
End Function
