I have a situation similar to Boolean backpack. I have a table with N lines. Column 'A' contains a footage (m²), column 'B' contains a price (R $).
I need to get all possible sums of column 'A' up to a certain value in meters (x) and, the best combination of sum of meters and value must be shown so that in meters, do not exceed the value 'x 'as stipulated.
In searches, I got a code that would at first solve the problem but I have got several errors, such as the variable 'Me' (I've never heard of it).
Follow the code. I would like the help to resolve the issue.
Option Explicit
'retirado comando private
Sub cmbBerechnen_Click()
Dim dblZielwert As Double
Dim dblToleranz As Double
Dim adblBeträge() As Double
Dim varResult As Variant
Dim m As Long
Dim n As Long
Dim gblnStop As Boolean
gblnStop = False
With Me
dblZielwert = .Range("B2")
dblToleranz = .Range("C2")
.Range("D2:IV65536").ClearContents
ReDim adblBeträge(1 To 100)
For m = 2 To 101
If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
adblBeträge(m - 1) = .Cells(m, 1)
Else
ReDim Preserve adblBeträge(1 To m - 1)
Exit For
End If
Next
ReDim Preserve adblBeträge(1 To UBound(adblBeträge) - 1)
MsgBox "Found Solutions : " & Kombinations(adblBeträge, dblZielwert, Me, 4, 2, dblToleranz)
Application.StatusBar = False
End With
Call CompileOutput
End Sub
Private Sub cmdAbbrechen_Click()
gblnStop = True
End Sub
Option Explicit
' Set to "True" for Stop
Public gblnStop As Boolean
Public Function Kombinations(SourceNumbers As Variant, Target As Double, DestSheet As Worksheet, _
DestCol As Long, DestRow As Long, Optional Tolerance As Double, Optional Previously As Variant, _
Optional ActLevel As Long, Optional ActFound As Long) As Long
Dim i As Long
Dim k As Long
Dim dblCompare As Double
Dim dblDummy As Double
Dim varDummy As Variant
' Do Other events (prevents for freeze)
DoEvents
' Global Variable to Stop when is set True
If gblnStop = True Then Exit Function
If Not IsMissing(Previously) Then
' Calculate Sum
For Each varDummy In Previously
dblCompare = dblCompare + varDummy
Next
Else
' First time call
' Sort source by size
For i = 1 To UBound(SourceNumbers)
For k = i + 1 To UBound(SourceNumbers)
If SourceNumbers(k) < SourceNumbers(i) Then
dblDummy = SourceNumbers(i)
SourceNumbers(i) = SourceNumbers(k)
SourceNumbers(k) = dblDummy
End If
Next
Next
' Make new collection
Set Previously = New Collection
End If
If ActLevel = 0 Then ActLevel = LBound(SourceNumbers)
For i = ActLevel To UBound(SourceNumbers) ' Test all Numbers
' Add act Value to Collection
Previously.Add SourceNumbers(i)
' Calculate act sum
dblCompare = dblCompare + SourceNumbers(i)
If Abs(Target - dblCompare) < (0.01 + Tolerance) Then 'trying to set the limit
' Act sum is in target range
k = DestCol - 1 ' Calculate Destination Column
ActFound = ActFound + 1 ' Count Solutions
With DestSheet
' Save Solution Array in Worksheet
For Each varDummy In Previously
k = k + 1
.Cells(DestRow - 1 + ActFound, k) = varDummy
Next
End With
' Delete following line, or set finally
' Statusbar to "False"
Application.StatusBar = "Solutions Count : " & ActFound
' Remove act Value from Collection
Previously.Remove Previously.Count
ElseIf dblCompare < (Target + 0.01 + Tolerance) Then
' Act sum is lower then target range
' Recursive call the same Function with
' higher Level
Kombinations SourceNumbers, Target, DestSheet, DestCol, DestRow, _
Tolerance, Previously, i + 1, ActFound
' Remove act Value from Collection
Previously.Remove Previously.Count
' Remove act Value from Sum
dblCompare = dblCompare - SourceNumbers(i)
Else
' Act sum is greater then target range
' No other Solutions possible in this level
Previously.Remove Previously.Count
Exit For
End If
Next ' Test with higher Number
Kombinations = ActFound
End FunctionAny idea how to make the code to roll?