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
SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
With ws.Sort
.SetRange rng
.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```
Oct 20, 2022 in Others 298 views

## 1 answer to this question.

Not at all. I used it. You have already called the sub findsum 79 million times with 20 base data points and 100 additional data points. There is a combinatorial explosion, and modifying the code won't be able to stop it. You must discover a more effective algorithm.
• 63,160 points

## Autofill Copy down up until next empty row- Excel VBA Macro

Row 1048576 will be returned by end(xldown) ...READ MORE

## Excel vba domdocument parsing xml from TNT tracking system: in some pcs object load return no document

This error is related to something in ...READ MORE

## Retrieve epay.info Balance with VBA and Excel

This code should log you in, provided ...READ MORE

## How to load file to Excel Power query from SFTP site

Currently, I don't think there is a ...READ MORE

## Using VBA Excel to create a gramatically correct list

The Excel AND function is a logical ...READ MORE