Sub XYZ()
Dim aMT_CBM(), aSL(), aGHan
Dim Dic As Object, ToHop, ikey
Dim sRow&, i&
Const sCol As Long = 3
aGHan = Array(0, 25, 2.8) 'Gioi Han dieu kien
aMT_CBM = Range("B4:C11").Value
aSL = Range("E4:E11").Value
sRow = UBound(aSL)
ReDim Res(1 To sRow, 1 To 3) 'Ket qua
Set Dic = CreateObject("scripting.dictionary")
For i = 1 To sRow 'Tao To Hop tung gia tri So Luong
ikey = aSL(i, 1)
If Dic.exists(ikey) = False Then
Call CreateToHopSoLuong(ToHop, sCol, ikey)
Dic.Add ikey, ToHop
End If
Next i
Call KetQua(Dic, aMT_CBM, aSL, aGHan, sRow, sCol)
End Sub
Private Sub KetQua(Dic, aMT_CBM, aSL, aGHan, sRow, sCol)
Dim ToHop, aRow(), aDKien(), Res()
Dim i&, j&, iR&, q As Double, N As Double, t As Double, iMin&, dem&
ReDim aRow(1 To sRow + 1) 'Tao mang xac dinh thu tu dong
aRow(sRow + 1) = 1
For i = sRow To 1 Step -1
aRow(i) = UBound(Dic.Item(aSL(i, 1))) * aRow(i + 1)
Next i
N = aRow(1) 'So kha nang
iMin = sRow * sCol + 1
For q = 1 To N
dem = 0
ReDim Res(1 To sRow, 1 To sCol)
ReDim aDKien(1 To 2, 1 To sCol) 'Mang xet dieu kien
For i = 1 To sRow
t = q - 1
Do While t >= aRow(i)
t = t - aRow(i)
Loop
iR = Int(t / aRow(i + 1)) + 1
ToHop = Dic.Item(aSL(i, 1))
For j = 1 To sCol
Res(i, j) = ToHop(iR, j)
For m = 1 To 2
aDKien(m, j) = aDKien(m, j) + Res(i, j) * aMT_CBM(i, m)
If aDKien(m, j) > aGHan(m) Then GoTo TroLai
Next m
Next j
dem = dem + ToHop(iR, sCol + 1)
Next i
If iMin > dem Then
Range("F4").Resize(sRow, sCol) = Res
iMin = dem
If iMin = sRow Then Exit Sub
End If
TroLai:
Next q
End Sub
Private Sub CreateToHopSoLuong(ToHop, sCol, ByVal SL As Long)
Dim sArr(), aRow(), tmp(), i&, j&, q&, iR&, N&, tong&
ReDim aRow(1 To sCol) 'Tao mang xac dinh thu tu dong
aRow(sCol) = 1
For j = sCol - 1 To 1 Step -1
aRow(j) = (SL + 1) * aRow(j + 1)
Next j
N = aRow(1)
ReDim sArr(1 To N, 1 To sCol + 1)
For i = 1 To N
tong = 0
ReDim tmp(1 To sCol)
For j = 1 To sCol - 1
iR = ((i - 1) Mod aRow(j)) \ aRow(j + 1)
tong = tong + iR
If tong > SL Then Exit For
tmp(j) = iR
If iR > 0 Then tmp(sCol) = tmp(sCol) + 1 ' so gia tri ket qua >0
Next j
If j = sCol Then
k = k + 1
For q = 1 To sCol - 1
sArr(k, q) = tmp(q)
Next q
sArr(k, sCol) = SL - tong
If sArr(k, sCol) > 0 Then tmp(sCol) = tmp(sCol) + 1 ' so gia tri ket qua >0
sArr(k, sCol + 1) = tmp(sCol) ' so gia tri ket qua >0
End If
Next i
ReDim ToHop(1 To k, 1 To sCol + 1) 'Tao mang ToHop
For i = 1 To k
For j = 1 To sCol + 1
ToHop(i, j) = sArr(i, j)
Next j
Next i
Erase sArr: Erase aRow: Erase tmp
End Sub
