Dùng cách vét cạn và tìm cách tăng tốc xử lý nên code khá phức tạp, kết quả liệt kê tất cả các trường hợp mua chung
Kiểm tra lại kết quả
Mã:
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
