Excel VBA背包类程序性能优化：解决大行数运行卡顿问题

我编写了一个类似背包算法的Excel VBA程序，当处理超过30行数据时，运行耗时极长甚至卡顿，请求帮忙优化代码以提升运行速度。

程序逻辑说明 #

• 基础表输入：A列为目标值（示例：1555），B列为分配标识（示例：A1），C、D列为筛选条件，用于匹配数据表。
• 工作流程：读取基础表第2行起的数据，在数据表中按C、D列条件筛选，从数据表C列中寻找最接近目标值的组合，为对应行分配基础表B列的标识，循环处理所有行。

运行方式 #

将代码复制到新工作簿，执行宏后选择基础表和数据表文件，程序会在数据表中完成分配。

现有代码 #

主程序 #

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

内容的提问来源于stack exchange，提问作者Adam