Option Explicit
Sub A_Solver_Toanbo()
Dim Ten
Dim Nguon, Slpt
Dim Min, Max
Dim Tong
Dim TongR
Dim TH, THMR
Dim BangTra
Dim Ptgh
Dim Thang, Tam
Dim DicTt As New Scripting.Dictionary
Dim DicKq As New Scripting.Dictionary
Dim DicLuu As New Scripting.Dictionary
Dim Kq
Dim r, rw, rs, rws, c, cl, cs, cls, i, j, k, x, z, t, Tm
Tm = Timer
With Sheet1
Ten = .Range("A3:A7")
Nguon = .Range("B3:B7")
Tong = .Range("B1")
End With
'TIM MIN, MAX, TINH CAC PHAN TU GOC
For r = 1 To UBound(Nguon)
k = Fix(Tong / Nguon(r, 1))
For cl = 1 To k
j = Nguon(r, 1) * cl
If DicLuu.Exists(j) = False Then
DicLuu(j) = Array(Array(Nguon(r, 1)), cl, Ten(r, 1))
Else
Tam = DicLuu(j)
k = UBound(Tam)
ReDim Preserve Tam(k + 1)
Tam(k + 1) = Array(Array(Nguon(r, 1)), cl, Ten(r, 1))
DicLuu(j) = Tam
End If
If Max < j Then Max = j
Next cl
Next r
Slpt = DicLuu.Count
'XONG TIM MIN, MAX, TINH CAC PHAN TU GOC
'SORT NGUON MAX_MIN
Nguon = DicLuu.Keys
ReDim Thang(Max)
For i = 0 To Slpt - 1
Thang(Nguon(i)) = Thang(Nguon(i)) + 1
Next i
k = 0
For i = Max To 0 Step -1
If Thang(i) <> "" Then
k = k + Thang(i)
Thang(i) = k
End If
Next i
ReDim Tam(Slpt - 1)
For i = 0 To Slpt - 1
k = Thang(Nguon(i))
Thang(Nguon(i)) = Thang(Nguon(i)) - 1
Tam(k - 1) = Nguon(i)
Next i
Nguon = Tam
'XONG SORT NGUON MAX_MIN
'LAP BANG TRA
ReDim BangTra(Max)
For i = 0 To Slpt - 1
cls = Nguon(i)
BangTra(cls) = i
Next i
'XONG LAP BANG TRA
'TIM PHANTUGIOIHAN
k = 0
For i = Slpt - 1 To 0 Step -1
k = k + Nguon(i)
If k >= Tong Then
Ptgh = i
Exit For
End If
Next i
'XONG TIM PHANTUGIOIHAN
'LAP MANG THMR XUAT PHAT
DicTt.RemoveAll
For i = 0 To Ptgh 'CHI LAY TOI PHANTUGIOIHAN
cls = BangTra(Nguon(i))
DicTt(i) = Array(Array(Nguon(i)), Nguon(i), cls)
Next i
'XONG LAP MANG THMR XUAT PHAT
'TIM TOHOP
DicKq.RemoveAll
k = 0
Do While DicTt.Count
THMR = DicTt.Items
DicTt.RemoveAll
k = k + 1
For i = 0 To UBound(THMR)
TH = THMR(i)(0)
TongR = THMR(i)(1)
cls = THMR(i)(2)
ReDim Preserve TH(k)
For j = cls + 1 To Slpt - 1
If TongR + Nguon(j) = Tong Then
TH(k) = Nguon(j)
DicKq(DicKq.Count) = TH
Else
If TongR + Nguon(j) < Tong Then
TH(k) = Nguon(j)
cl = BangTra(Nguon(j))
DicTt(DicTt.Count) = Array(TH, TongR + Nguon(j), cl)
End If
End If
Next j
Next i
Loop
'XONG TIM TOHOP
'TRA KET QUA ( TINH CHO TRUONGHOP 1 PHAN TU DICLUU = 1 MANG )
Tam = DicKq.Items
ReDim Kq(1 To DicKq.Count, 1 To (k + 1) * 2)
For i = 0 To UBound(Tam)
THMR = Tam(i)
cls = UBound(THMR)
For j = 0 To cls
TH = DicLuu(THMR(j))
Kq(i + 1, j * 2 + 1) = TH(2)
Kq(i + 1, j * 2 + 2) = TH(1)
Next j
Next i
'XONG TRA KET QUA ( TINH CHO TRUONGHOP 1 PHAN TU DICLUU = 1 MANG )
With Sheet2
.UsedRange.Clear
.Range("A6").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
.UsedRange.Columns.AutoFit
.Range("A3") = DicKq.Count & "_" & k
.Range("A1") = Timer - Tm
End With
End Sub
