Please have a look at the code below, which runs for more than 30 rows in a range too slowly. (Its criteria resemble those of the knapsack algorithm)
Let me attempt to clarify in more detail below: Base sheet input With respect to the input data sheet file, Column C & D's filter values will be applied to Column A's values (for example, 1555), Column B's assignment value (A1), and Column A's values themselves.
The basic idea behind the program is as follows: it takes the first row (2) of data from the base sheet and applies the filter (C2 & D2 value) in the input data sheet (Columns A & B respectively). Next, it checks the value in column C and finds the best sum to match the value (1555) or the value that is closest to it. Finally, it assigns the value (which is A1) against those rows and repeats the process for the following rows.
I've included an image below. Please use the Input Base sheet and Input Data sheet as references and copy the scripts to a different worksheet. Run the macro, then choose the Base and Datasheets. The program would run and allocate the datasheet for input. When I have fewer rows, it runs incredibly quickly; when I have more rows, it hangs or takes too long to run.
Input base sheet
Input data sheet:
Sub sample1()
Dim lrow As Integer
Dim frow As Integer
Dim row As Integer
Dim ar As Variant
Dim aar As Variant
Dim Sol(), csol()
Dim arr As Variant
Dim pos As Integer
Dim arow() As Integer
Dim rng As Range
Dim rn As Range
Dim r As Range
Dim k As Integer
Dim itr As Integer
Dim path As String
Dim tm_base As Workbook
Dim tm_data As Workbook
Dim sh_base As Worksheet
Dim sh_data As Worksheet
Dim sh As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set sh = ActiveSheet
ReDim arr(0)
arr(0) = ""
path = FileSelection("Input Base")
If path = "" Then Exit Sub
Set tm_base = Workbooks.Open(path)
path = FileSelection("Input Data")
If path = "" Then Exit Sub
Set tm_data = Workbooks.Open(path)
Set sh_base = tm_base.ActiveSheet
Set sh_data = tm_data.ActiveSheet
lrow = sh_data.Cells(Rows.Count, "A").End(xlUp).row
frow = sh_base.Cells(Rows.Count, "A").End(xlUp).row
SortMacro ActiveSheet, sh_base.Range("A2:A" & frow), sh_base.Range("A1:G" & frow), 2
SortMacro ActiveSheet, sh_data.Range("C2:C" & lrow), sh_data.Range("A1:G" & lrow), 2
For row = 2 To frow
If sh_base.Cells(row, "H") <> "Done" Then
itr = 1
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4, Criteria1:="="
op2:
sh_data.Range("A1:G" & lrow).AutoFilter Field:=1, Criteria1:=sh_base.Cells(row, "C").Value
sh_data.Range("A1:G" & lrow).AutoFilter Field:=2, Criteria1:=sh_base.Cells(row, "D").Value
Set rn = Nothing
On Error Resume Next
Set rn = sh_data.Range("C2:C" & lrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rn Is Nothing Then
ReDim ar(0)
ReDim arow(0)
k = 1
For Each r In rn
ReDim Preserve arow(k)
ReDim Preserve ar(k)
ar(k) = r.Value
arow(k) = r.row
k = k + 1
Next
ReDim Sol(LBound(ar) To UBound(ar))
ReDim csol(LBound(ar) To UBound(ar))
limsum = sh_base.Cells(row, "A").Value
For i = LBound(ar) To UBound(ar)
If ar(i) > limsum Then
ar(i) = -1
End If
Next
maxsum = 0
findsum ar, Sol, csol, maxsum, limsum, UBound(ar), UBound(ar)
ss = ""
For i = 1 To Sol(0)
'ss = ss & sep & ar(sol(i))
'sep = ","
If Not arr(UBound(arr)) = "" Then
ReDim Preserve arr(UBound(arr) + 1)
End If
arr(UBound(arr)) = ar(Sol(i))
Next i
'MsgBox ss & " sum =" & maxsum
For j = LBound(arr) To UBound(arr)
pos = Application.Match(arr(j), ar, False)
If ar(pos - 1) > 0 Then
ar(pos - 1) = -1
End If
pos = arow(pos - 1)
If sh.Range("B1") = "Option 01" Then
sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value
Else
sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value & " " & Format(itr, "00")
End If
Next
ReDim arr(0)
arr(0) = ""
sh_base.Cells(row, "H") = "Done"
If sh.Range("B1") = "Option 02" Then
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4, Criteria1:="="
Set rng = sh_data.Range("A1:A" & lrow).SpecialCells(xlCellTypeVisible)
If rng.Cells.Count > 1 Then
itr = itr + 1
GoTo op2
End If
End If
End If
sh_data.Range("A1:G" & frow).AutoFilter Field:=1
sh_data.Range("A1:G" & frow).AutoFilter Field:=2
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub findsum(ByVal a, ByRef Sol, ByRef csol, ByRef maxsum, ByRef limsum, si, maxcount, Optional s = 0, Optional lvl = 1, Optional dif = 100000, Optional minuscount = 0, Optional tsol, Optional j = 0)
' recursive sub
For i = LBound(a) To si
If a(i) > 0 Then
If s + a(i) > limsum Then findsum a, Sol, csol, maxsum, limsum, i - 1, maxcount, s, lvl + 1, dif, minuscount, tsol
s = s + a(i)
csol(lvl) = i
If s <= limsum Then
If s > maxsum Then ' we found a sum greater than current max we save it
maxsum = s
Sol(0) = lvl
For j = 1 To lvl
Sol(j) = csol(j)
Next j
End If
If i > LBound(a) Then ' pick another number
findsum a, Sol, csol, maxsum, limsum, i - 1, maxcount, s, lvl + 1, dif, minuscount, tsol
End If
End If
s = s - a(i)
If maxsum = limsum Then Exit For 'exit if exact match
End If
Next i
End Sub
Sub SortMacro(ws As Worksheet, rn As Range, rng As Range, ord As Integer)
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=rn, _
SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
With ws.Sort
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Function FileSelection(file As String)
Dim path As String
Dim st As String
Dim i As Integer
Dim j As Integer
FileSelection = ""
With Application.FileDialog(3)
.title = "Select the " & file & " file"
.AllowMultiSelect = False
.InitialFileName = st
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You didn't select the file!", vbExclamation, "Canceled"
Exit Function
Else
FileSelection = .SelectedItems(1)
End If
End With
End Function
