algorithm - 减少算法的内存和执行时间

Question

有人要求我在稍微不同的背景下再次问这个问题。这是之前的帖子:

Filtering in VBA after finding combinations

我想用 100 个不同的变量使这段代码成为可能，而不会让 excel 耗尽内存并显着减少执行时间。

下面代码的问题是，如果我有 100 个盒子，excel 将在“结果(0 到 2 ^ NumFields - 2)”行中用完内存(该代码适用于 < 10 个盒子)

这是我的输入:

3   A   B   C   D   E ...
7.7 3   1   1   1   2 ...
5.5 2   1   2   3   3 ...

这是代码:

Function stackBox()
    Dim ws As Worksheet
    Dim width As Long
    Dim height As Long
    Dim numOfBox As Long
    Dim optionsA() As Variant
    Dim results() As Variant
    Dim str As String
    Dim outputArray As Variant
    Dim i As Long, j As Long
    Dim currentSymbol As String
    '------------------------------------new part----------------------------------------------
    Dim maxHeight As Double
    Dim maxWeight As Double
    Dim heightarray As Variant
    Dim weightarray As Variant
    Dim totalHeight As Double
    Dim totalWeight As Double
    '------------------------------------new part----------------------------------------------

    Set ws = Worksheets("Sheet1")
    With ws
        'clear last time's output
        height = .Cells(.Rows.Count, 1).End(xlUp).row
        If height > 3 Then
            .Range(.Cells(4, 1), .Cells(height, 1)).ClearContents
        End If

        numOfBox = .Cells(1, 1).Value
        width = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If width < 2 Then
            MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..."
            Exit Function
        End If


        '------------------------------------new part----------------------------------------------
        maxHeight = .Cells(2, 1).Value
        maxWeight = .Cells(3, 1).Value
        ReDim heightarray(1 To 1, 1 To width - 1)
        ReDim weightarray(1 To 1, 1 To width - 1)
        heightarray = .Range(.Cells(2, 2), .Cells(2, width)).Value
        weightarray = .Range(.Cells(3, 2), .Cells(3, width)).Value
        '------------------------------------new part----------------------------------------------

        ReDim optionsA(0 To width - 2)
        For i = 0 To width - 2
            optionsA(i) = .Cells(1, i + 2).Value
        Next i

        GenerateCombinations optionsA, results, numOfBox


        ' copy the result to sheet only once
        ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1)
        Count = 0
        For i = LBound(results, 1) To UBound(results, 1)
            If Not IsEmpty(results(i)) Then
                'rowNum = rowNum + 1
                str = ""
                totalHeight = 0#
                totalWeight = 0#
                For j = LBound(results(i), 1) To UBound(results(i), 1)
                    currentSymbol = results(i)(j)

                    str = str & currentSymbol 'results(i)(j) is the SYMBOL e.g. A, B, C

                    'look up box's height and weight , increment the totalHeight/totalWeight
                    updateParam currentSymbol, optionsA, heightarray, weightarray, totalHeight, totalWeight

                Next j
                If totalHeight < maxHeight And totalWeight < maxWeight Then
                    Count = Count + 1
                    outputArray(Count, 1) = str
                End If

            '.Cells(rowNum, 1).Value = str
            End If
        Next i
        .Range(.Cells(4, 1), .Cells(UBound(outputArray, 1) + 3, 1)).Value = outputArray
    End With

End Function

Sub updateParam(ByRef targetSymbol As String, ByRef symbolArray As Variant, ByRef heightarray As Variant, ByRef weightarray As Variant, ByRef totalHeight As Double, ByRef totalWeight As Double)
Dim i As Long
Dim index As Long
index = -1
For i = LBound(symbolArray, 1) To UBound(symbolArray, 1)
    If targetSymbol = symbolArray(i) Then
        index = i
        Exit For
    End If
Next i


If index <> -1 Then
    totalHeight = totalHeight + heightarray(1, index + 1)
    totalWeight = totalWeight + weightarray(1, index + 1)
End If
End Sub

Sub GenerateCombinations(ByRef AllFields() As Variant, _
                                             ByRef Result() As Variant, ByVal numOfBox As Long)

  Dim InxResultCrnt As Integer
  Dim InxField As Integer
  Dim InxResult As Integer
  Dim i As Integer
  Dim NumFields As Integer
  Dim Powers() As Integer
  Dim ResultCrnt() As String

  NumFields = UBound(AllFields) - LBound(AllFields) + 1

  ReDim Result(0 To 2 ^ NumFields - 2)  ' one entry per combination
  ReDim Powers(0 To NumFields - 1)          ' one entry per field name

  ' Generate powers used for extracting bits from InxResult
  For InxField = 0 To NumFields - 1
    Powers(InxField) = 2 ^ InxField
  Next

 For InxResult = 0 To 2 ^ NumFields - 2
    ' Size ResultCrnt to the max number of fields per combination
    ' Build this loop's combination in ResultCrnt

    ReDim ResultCrnt(0 To NumFields - 1)
    InxResultCrnt = -1
    For InxField = 0 To NumFields - 1
      If ((InxResult + 1) And Powers(InxField)) <> 0 Then
        ' This field required in this combination
        InxResultCrnt = InxResultCrnt + 1
        ResultCrnt(InxResultCrnt) = AllFields(InxField)
      End If
    Next

    If InxResultCrnt = 0 Then
        Debug.Print "testing"
    End If
    'additional logic here
    If InxResultCrnt >= numOfBox Then
        Result(InxResult) = Empty

    Else
         ' Discard unused trailing entries
        ReDim Preserve ResultCrnt(0 To InxResultCrnt)
        ' Store this loop's combination in return array
        Result(InxResult) = ResultCrnt
    End If

  Next

End Sub

Answer 1

这是一个在变体数组中完成所有繁重工作的版本

(组合逻辑基于 This Answer 的 Joubarc 答案)

这在包含 100 个盒子的样本数据集上运行，返回了 > 40,000 个，并且在 < 1 秒内

注意事项:

1. 如果框的最大数量增加，执行时间会迅速增加(例如，从 100 到 4:大约 13 秒)
2. 如果返回的结果数超过 65535，则将数组转置到工作表中的代码将失败(子句的最后一行)如果您需要处理这种可能的结果，则需要更改返回结果的方式工作表

---

Sub Demo()
    Dim rNames As Range
    Dim rHeights As Range
    Dim rWeights As Range

    Dim aNames As Variant
    Dim aHeights As Variant
    Dim aWeights As Variant

    Dim MaxNum As Long
    Dim MaxHeight As Double
    Dim MaxWeight As Double

    ' *** replace these six line with your data ranges
    Set rNames = Range([F5], [F5].End(xlToRight))
    Set rHeights = rNames.Offset(1, 0)
    Set rWeights = rNames.Offset(2, 0)
    MaxNum = [C5]
    MaxHeight = [C6]
    MaxWeight = [C7]

    aNames = rNames
    aHeights = rHeights
    aWeights = rWeights

    Dim Result() As Variant
    Dim n As Long, m As Long
    Dim i As Long, j As Long
    Dim iRes As Long
    Dim res As String
    Dim TestCombin() As Long
    Dim TestWeight As Double
    Dim TestHeight As Double
    Dim idx() As Long

    ' Number of boxes
    ReDim TestCombin(0 To MaxNum - 1)
    n = UBound(aNames, 2) - LBound(aNames, 2) + 1

    ' estimate size of result array = number of possible combinations
    For m = 1 To MaxNum
        i = i + Application.WorksheetFunction.Combin(n, m)
    Next
    ReDim Result(1 To 3, 1 To i)

    ' allow for from 1 to MaxNum of boxes
    iRes = 1
    For m = 1 To MaxNum
        ReDim idx(0 To m - 1)
        For i = 0 To m - 1
            idx(i) = i
        Next i

        Do
            'Test current combination
            res = ""
            TestWeight = 0#
            TestHeight = 0#
            For j = 0 To m - 1
                'Debug.Print aNames(1, idx(j) + 1);
                res = res & aNames(1, idx(j) + 1)
                TestWeight = TestWeight + aWeights(1, idx(j) + 1)
                TestHeight = TestHeight + aHeights(1, idx(j) + 1)
            Next j
            'Debug.Print
            If TestWeight <= MaxWeight And TestHeight <= MaxHeight Then
                Result(1, iRes) = res
                ' optional, include actual Height and Weight in result
                Result(2, iRes) = TestHeight
                Result(3, iRes) = TestWeight
                iRes = iRes + 1
            End If

            ' Locate last non-max index
            i = m - 1
            While (idx(i) = n - m + i)
                i = i - 1
                If i < 0 Then
                    'All indexes have reached their max, so we're done
                    Exit Do
                End If
            Wend

            'Increase it and populate the following indexes accordingly
            idx(i) = idx(i) + 1
            For j = i To m - 1
                idx(j) = idx(i) + j - i
            Next j
        Loop
    Next

    ' Return Result to sheet    
    Dim rng As Range
    ReDim Preserve Result(1 To 3, 1 To iRes)

    ' *** Adjust returnm range to suit
    Set rng = [E10].Resize(UBound(Result, 2), UBound(Result, 1))
    rng = Application.Transpose(Result)
End Sub