Option Explicit
Sub Main()
Dim sArr(), aDK(), arr, rngTT As Range, rng As Range, tmp$
Dim K&, sRow&, sR&, j&, i&, r&, iR&, t#
Const xMax& = 200
t = Timer
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Sheet2").Activate
aDK = Range("D2:I2").Value
sArr = Range("D10:I19").Value
sRow = UBound(sArr)
Call SoBuocMin(sArr, aDK, K, sRow, xMax)
Range("C10").Resize(sRow).ClearContents
Set rngTT = Range("C10").Resize(sRow)
For j = K To sRow
arr = Tohop_N_Chap_K(sRow, j)
sR = UBound(arr)
Set rng = Range("L10").Resize(j)
For i = 1 To sR
rng = 0: iR = 0
tmp = arr(i, 1)
rngTT.ClearContents
For r = 1 To sRow
If Mid(tmp, r, 1) = "1" Then
iR = iR + 1
rngTT(r, 1).Formula = "=" & rng(iR, 1).Address
End If
Next r
If i = 1 Then Call SolverVBA(rng.Address) Else SolverSolve True
If Range("L4").Value = 0 Then MsgBox Timer - t & " Giay": Exit Sub
Next i
Next j
Application.ScreenUpdating = True
End Sub
Private Function Tohop_N_Chap_K(ByVal N As Integer, ByVal K As Integer) As Variant
'Tao to hop N chap K, bieu dien bang chuoi các ký tu "0" va "1"
'Thu tu gia tri "1" là thu tu du lieu nguon lay du lieu
Dim arr() As String, tmp$, j&, p&, s&
ReDim arr(1 To Application.Combin(N, K), 1 To 1)
tmp = String(K, "1") & String(N - K, "0")
p = 1: arr(p, 1) = tmp
If K = N Then Tohop_N_Chap_K = arr: Exit Function
Do
j = InStrRev(tmp, "1")
Mid(tmp, j, 1) = "0"
Mid(tmp, j + 1, s + 1) = String(s + 1, "1")
s = 0: p = p + 1: arr(p, 1) = tmp
If InStr(j + 1, tmp, "0") = 0 Then
s = N - j
Mid(tmp, j + 1, s) = String(s, "0")
End If
Loop Until s = K
Tohop_N_Chap_K = arr
End Function
Private Sub SoBuocMin(sArr, aDK, K, sRow, xMax)
Dim arr(), i&, j&, tmp#
For j = 1 To 6
tmp = 0
Range("C10:C19").Offset(, j).Sort Range("C10").Offset(, j), 1, Header:=xlNo
arr = Range("C10:C19").Offset(, j).Value
For i = 1 To sRow
tmp = tmp + arr(i, 1) * xMax
If tmp >= aDK(1, j) Then Exit For
Next i
If K < i Then K = i
Next j
If K > sRow Then K = sRow
Range("D10:I19").Value = sArr
End Sub
Private Sub SolverVBA(ByVal ChangeCells$)
SolverReset
SolverOk SetCell:="$L$4", MaxMinVal:=2, ValueOf:=0, ByChange:=ChangeCells, _
Engine:=2, EngineDesc:="Simplex LP"
SolverAdd CellRef:="$D$4:$I$4", Relation:=2, FormulaText:="0"
SolverAdd CellRef:=ChangeCells, Relation:=3, FormulaText:="0"
SolverAdd CellRef:=ChangeCells, Relation:=1, FormulaText:="200"
SolverAdd CellRef:=ChangeCells, Relation:=4, FormulaText:="integer"
SolverSolve True
End Sub
