Speed up Excel vba program

0 votes

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

base sheet

Input data sheet:

datas 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:="="
        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
            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
            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
                    sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value & " " & Format(itr, "00")
                End If
            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

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.Add Key:=rn, _
        SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange rng
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
    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
    If .SelectedItems.Count = 0 Then
        MsgBox "You didn't select the file!", vbExclamation, "Canceled"
        Exit Function
        FileSelection = .SelectedItems(1)
    End If
End With
End Function
Oct 20 in Others by Kithuzzz
• 20,660 points

1 answer to this question.

0 votes
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.
answered Oct 20 by narikkadan
• 37,660 points

Related Questions In Others

0 votes
1 answer

Language independent way to get "My Documents" folder in VBA Excel 2003

 Hello :)  This code may help you in your ...READ MORE

answered Feb 16 in Others by Edureka
• 13,640 points
0 votes
1 answer
0 votes
1 answer

Runtime error 438 while importing data in excel from secured website using VBA

Replace With ieDoc.forms(0) .userType.Value = "1" ...READ MORE

answered Sep 23 in Others by narikkadan
• 37,660 points
0 votes
1 answer

VBA excel - create skype account using powershell script

Although the PowerShell portion has not been ...READ MORE

answered Sep 23 in Others by narikkadan
• 37,660 points
0 votes
1 answer

Retrieve epay.info Balance with VBA and Excel

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

answered Sep 5, 2018 in Blockchain by digger
• 26,720 points
0 votes
1 answer

How to load file to Excel Power query from SFTP site

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

answered Dec 3, 2018 in Power BI by Upasana
• 8,620 points
0 votes
1 answer

Using VBA Excel to create a gramatically correct list

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

answered Feb 9 in Others by gaurav
• 22,040 points
0 votes
2 answers

How to copy a formula horizontally within a table using Excel VBA?

Hi so basically, create an adjacent column ...READ MORE

answered Feb 16 in Others by Edureka
• 13,640 points
0 votes
1 answer

Excel VBA if file closed, then open and paste, else just paste data

Slightly re-worked to add full workbook/sheet qualifiers ...READ MORE

answered Sep 21 in Others by narikkadan
• 37,660 points
0 votes
1 answer
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP