Vba excel中的组合数学：查找每个可能组合的每个可能和

好的，我发现了类似的问题，但没有一个能解决这个问题，所以我来：

我有一个a列的个人列表，每个人都有一个为确定的参数B列指定的值。 我有一些目标参数值，我想知道哪些个体组合对该参数值求和x

让我们举一个例子：

      Col. A                      Col. B

       M                            10
       N                           -5
       O                           -8
       P                            0.87
       Q                            9

     - Target for Parameter("X"): 9-10

     - Solution:
                S1= Q+P -> 9.87
                S2= Q   -> 9

正如您通过检查所看到的，唯一的方法是采用Q或Q+p。 但就我而言，我每次都有10-15个科目，通过检查来完成这项工作一点也不容易

---

我想生成一个图表，其中所有可能的值都能够知道哪些受试者正在生成值，或者只是一种知道y个最接近的组合的方法。

原始问题涉及5个值，暴力方法是可以接受的。然后增加数值的数量，需要更复杂的方法。我建议您从这个答案开始，它描述了暴力方法，然后是：

第一个答案

您需要将您的需求分解为许多简单的步骤。可以组合两个或多个步骤，但复杂的步骤需要更多的编写时间和调试时间。从简单开始。一旦你的代码开始工作，你就可以担心做得更快或更漂亮，或者做任何必要的事情。太多的程序员忘记了快速、漂亮、不起作用的代码是无用的

我创建了一个工作表“源”，并用值填充它，以便：

我需要把最小值和最大值放在某个地方，所以我把它们放在这张工作表上

我创建了一个工作表“结果”。以下宏的输出为：

您没有将“10 M”列为解决方案。我不知道这是否是疏忽，或者你对“9-10”范围的解释是否与我的不同。如果ValueMin=ValueCrnt，则在必要时更改该行

Option Explicit

  ' * I have a system for allocating names to my constants and variables.
  '   I can look at macros I wrote years ago and immediately know the
  '   purpose of the variables. This is a real help if I need to enhance
  '   an old macro.
  ' * If you do not like my system, develop your own.
  ' * My names are a sequence of words each of which reduces the scope
  '   of the variable.
  ' * Typically, the first word identified the purpose:
  '     Inx  index into a 1D array
  '     Col  a column of a worksheet or a 2D array
  '     Row  a row of a worksheet or a 2D array
  '     Wsht something to do with a worksheet
  ' * If I have more than worksheet, I will have a keyword to identify
  '   which worksheet a variable is used for:
  '     ColSrc   a column of the source worksheet
  '     RowRslt  a row of a results worksheet
  '     ColKV    a column of the KeyValue array

  ' Although most constants are only used by one routine, some are used by
  ' more than one. I have defined all as global so all constants are together.
  ' ==========================================================================

  ' * Changes values if the minimum and maximum values are moved.
  ' * The code assumes both values are in the Source worksheet.
  Const CellSrcMin As String = "C3"
  Const CellSrcMax As String = "D3"

  ' * The leftmost column will always be 1 no matter what
  '   columns the KeyValue table occupies in the worksheet
  ' * Reverse values if the columns are swapped
  Const ColKVKey As Long = 1
  Const ColKVValue As Long = 2

  ' * Reverse values if the columns are swapped
  Const ColRsltValue As String = "A"
  Const ColRsltExpnKey As String = "B"
  Const ColRsltExpnValue As String = "C"

  ' * Change both of these constants if the KeyValue table
  '   does not start in column A of the worksheet
  Const ColSrcKVFirst As String = "A"
  Const ColSrcKVLast As String = "B"

  ' * Change both of these constants if the KeyValue table
  '   does not start in column A of the worksheet
  ' * Reverse values if the columns are swapped
  Const ColSrcKVKey As String = "A"
  Const ColSrcKVValue As String = "B"

  ' Increase value if a second or third header row is added
  ' Reduce value to 1 if there is no header row
  Const RowSrcDataFirst As Long = 2

  ' Change values to match worksheet names
  Const WshtRsltName As String = "Result"
  Const WshSrcName As String = "Source"

  ' Variables used by more than one routine
  ' =======================================

  ' The KeyValue table will be loaded from the source worksheet to this
  ' variant as a 2D array
  Dim KeyValue As Variant

  ' Row in results worksheet to which the next result will be written
  Dim RowRsltNext As Long

Sub Control2()

  ' If one of the tests of the last entry in the pending arrays
  ' indicate that entry should be deleted, set to True.
  Dim DeleteEntry As Boolean

  ' The current last used entry in the pending arrays
  Dim InxPendingCrntMax As Long

  ' Number of combinations tested
  Dim NumTested As Long

  ' * The Pending arrays hold information about combinations that are pending;
  '   that is, combinations that have not been accepted as having an in-range
  '   total and have not been rejected as having an above maximum total.
  ' * The value of an entry in PendingWhichKeys might be "++-+". This means
  '   that this combination contains the first, second and fourth values but not
  '   the third. The corresponding entry in PendingTotal will contain the total
  '   of the first, second and fourth values.
  Dim PendingWhichKeys() As String
  Dim PendingTotal() As Double

  ' * Rows within KeyValue.
  ' * RowKVFirst is the control variable for the outer For-Loop. A value of N
  '   means this repeat considers combinations that start with the Nth value.
  ' * RowKVCrnt is used in the inner Do-Loop. It is set to the number of the
  '   next row to be considered for addition to a combination.
  Dim RowKVFirst As Long
  Dim RowKVCrnt As Long

  ' The last row of the KeyValue table within the source worksheet
  Dim RowSrcDataLast As Long

  ' Used to calculate the duration of a run.  Set by Timer to the number of
  ' seconds since midnight. The value includes fractions of a second but I
  ' cannot find any documentation that specifies how accurate the time is.
  ' I suspect it depends on the clock speed.  Anyway, with OS and other
  ' background routines running at any time, no timings are that accurate.
  Dim TimeStart As Double

  ' The minimum and maximum values are copied from the
  ' source worksheet to these variables.
  Dim TotalMax As Double
  Dim TotalMin As Double

  TimeStart = Timer

  With Worksheets(WshSrcName)

    ' Find last row in KeyValue table
    RowSrcDataLast = .Cells(Rows.Count, ColSrcKVKey).End(xlUp).Row

    ' Sort KeyValue table within worksheet by value
    .Range(.Cells(RowSrcDataFirst, ColSrcKVKey), _
           .Cells(RowSrcDataLast, ColSrcKVValue)) _
       .Sort Key1:=.Range(ColSrcKVValue & RowSrcDataFirst), _
             Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
             MatchCase:=False, Orientation:=xlTopToBottom, _
             DataOption1:=xlSortNormal

    ' KeyValue is of data type Variant (meaning it can hold anything).
    ' This statement loads all the data from a range and places it in KeyValue
    ' as a 2D array. The first dimension will be for rows and the second for
    ' columns. Both lower bounds will be 1 regardless of where the range was
    ' located.
    KeyValue = .Range(.Cells(RowSrcDataFirst, ColSrcKVFirst), _
                     .Cells(RowSrcDataLast, ColSrcKVLast)).Value

    ' Get the minimum and maximum required values
    TotalMin = .Range(CellSrcMin).Value
    TotalMax = .Range(CellSrcMax).Value

  End With

  ' Initialise result worksheet
  With Worksheets(WshtRsltName)
    .Cells.EntireRow.Delete
    With .Range("A1")
      .Value = "Total"
      .HorizontalAlignment = xlRight
    End With
    .Range("B1").Value = "Key Expn"
    .Range("C1").Value = "Value Expn"
    .Range("A1:C1").Font.Bold = True
    ' This value will be overwritten if any combination gives an acceptable value
    .Range("A2").Value = "No combination gives a total in the range " & _
                         TotalMin & " to " & TotalMax
  End With
  RowRsltNext = 2

  ' The maximum pending entries is the number of rows in the KeyValue table
  ReDim PendingWhichKeys(1 To UBound(KeyValue, 1))
  ReDim PendingTotal(1 To UBound(KeyValue, 1))

  NumTested = 0

  ' Each repeat of this loop considers the combinations that
  ' start with the KeyValue from RowKVFirst.
  For RowKVFirst = 1 To UBound(KeyValue, 1)

    If KeyValue(RowKVFirst, ColKVValue) > TotalMax Then
      ' The value of the first entry is above the maximum acceptable value.
      ' Any further values will be even larger so there are no more combinations
      ' that could be acceptable
      Exit For
    End If

    ' Create entries in the pending arrays for the shortest combination
    ' being considered during this repeat of the outer loop.
    PendingWhichKeys(1) = "+"
    PendingTotal(1) = KeyValue(RowKVFirst, ColKVValue)
    InxPendingCrntMax = 1        ' The last currently used entry
    NumTested = NumTested + 1

    Do While InxPendingCrntMax > 0
      ' Examine last entry in pending arrays:
      '  * if total is within range, add entry to results worksheet
      '  * if adding the value of the next KeyValue would cause the total
      '    to exceed the maximum, delete entry from pending arrays
      '  * if the last row of the KeyValue table has been considered for
      '    inclusion in the combination, delete entry from pending arrays
      '  * if the entry is not to be deleted:
      '      * create new entry in pending arrays.
      '      * copy the previous last entry to this new entry but with an
      '        extra "-" at the end of the PendingWhichKeys entry
      '      * Add "+" to end of PendingWhichKeys entry and add appropriate
      '        value to PendingTotal entry

      If PendingTotal(InxPendingCrntMax) >= TotalMin And _
         PendingTotal(InxPendingCrntMax) <= TotalMax Then
        ' This is an acceptable value
        If Right(PendingWhichKeys(InxPendingCrntMax), 1) = "+" Then
          ' This combination has not been output before
          Call OutputResult(RowKVFirst, PendingWhichKeys(InxPendingCrntMax), _
               PendingTotal(InxPendingCrntMax))
        End If
      End If

      DeleteEntry = False
      ' Identify next row of KeyValue that could be added to combination
      RowKVCrnt = RowKVFirst + Len(PendingWhichKeys(InxPendingCrntMax))
      If RowKVCrnt > UBound(KeyValue, 1) Then
        ' All rows have been considered for addition to this combination
        DeleteEntry = True
      ElseIf PendingTotal(InxPendingCrntMax) + KeyValue(RowKVCrnt, ColKVValue) _
                                                          > TotalMax Then
        ' Adding another value to this combination would cause it to exceed
        ' the maximum value.  Because of the sort, any other values will be
        ' larger than the current value so no extension to this combination
        ' need be considered.
        DeleteEntry = True
      End If

      If DeleteEntry Then
        ' Abandon this combination
        InxPendingCrntMax = InxPendingCrntMax - 1
      Else
        ' Extend this combination
        ' Create new combination based on non-addition of current row
        ' to current combination
        PendingWhichKeys(InxPendingCrntMax + 1) = _
                                            PendingWhichKeys(InxPendingCrntMax) & "-"
        PendingTotal(InxPendingCrntMax + 1) = PendingTotal(InxPendingCrntMax)
        ' Add current row to existing combination
        PendingWhichKeys(InxPendingCrntMax) = _
                                            PendingWhichKeys(InxPendingCrntMax) & "+"
        PendingTotal(InxPendingCrntMax) = PendingTotal(InxPendingCrntMax) + _
                                                      KeyValue(RowKVCrnt, ColKVValue)
        InxPendingCrntMax = InxPendingCrntMax + 1
        ' I consider both the new and the amended entries as new tests
        NumTested = NumTested + 2
      End If
    Loop
  Next

  With Worksheets(WshtRsltName)
    .Columns("A:C").AutoFit
  End With

  Debug.Print "Number keys " & UBound(KeyValue, 1)
  Debug.Print "Number tested " & NumTested
  Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.00")

End Sub
Sub OutputResult(ByVal RowKVFirst As Long, ByVal WhichKeys As String, _
                 ByVal Total As Double)

  ' Output a result to result worksheet

  ' Global variables:
  '  * KeyValue
  '  * RowRsltNext

  ' Parameters:
  '  * RowKVFirst  Identifies the first row in KeyValue being considered
  '                currently. KeyValues in rows 1 to RowKVFirst-1 are not
  '                within the current combination.
  '  * WhichKeys   Identifies which KeyValues are present in the current
  '                combination.  If the value is "++-+" then:
  '                 * Row RowKVFirst   selected
  '                 * Row RowKVFirst+1 selected
  '                 * Row RowKVFirst+2 not selected
  '                 * Row RowKVFirst+3 selected
  '                 * Row RowKVFirst+4, if present, and any following rows
  '                   not selected
  '  * Total       The total value of the current combination.

  Dim ExpnKey As String
  Dim ExpnValue As String
  Dim PosWhichKeys As Long
  Dim RowKVCrnt As Long

  With Worksheets(WshtRsltName)
    ' Output total for combination
    .Cells(RowRsltNext, ColRsltValue) = Total
    ' Create key string
    ' Get Key and Value from first row within combination
    ExpnKey = KeyValue(RowKVFirst, ColKVKey)
    ExpnValue = KeyValue(RowKVFirst, ColKVValue)
    ' Add keys and values from any other rows
    For PosWhichKeys = 2 To Len(WhichKeys)
      If Mid(WhichKeys, PosWhichKeys, 1) = "+" Then
        ' This rows is within combination
        RowKVCrnt = RowKVFirst + PosWhichKeys - 1
        ExpnKey = ExpnKey & "+" & KeyValue(RowKVCrnt, ColKVKey)
        ExpnValue = ExpnValue & "+" & KeyValue(RowKVCrnt, ColKVValue)
      End If
    Next
    .Cells(RowRsltNext, ColRsltExpnKey) = ExpnKey
    .Cells(RowRsltNext, ColRsltExpnValue) = ExpnValue
    RowRsltNext = RowRsltNext + 1
  End With

End Sub

我注意到我的列与你的列顺序不同。这是一个简单的改变，我留给你们作为练习

我的解决方案有三个主要步骤

第一步

在我的工作表上，相关数据在第2行到第6行。您表示要添加更多值。起始行是固定的，因此我使用常量定义它：

Const RowSrcDataFirst As Long = 2 

包含数据的最后一行RowSrcDataLast的值由代码确定

步骤2

虽然您的目标是处理键和值，但在此阶段您对行感兴趣。例如：

第2行上的值是否在要求的范围内？ 第2行和第3行上的值之和是否在要求的范围内？ 第2、4和6行上的值之和是否在要求的范围内？ 如果这些问题的答案为“是”，则根据键创建表达式

您需要行号来获取键和值

My宏使用值2到RowSrcDataLast填充数组SrcRows。然后它调用一个子例程GenerateCombinations。我使用此子例程的变体来解决任何此类问题

GenerateCompositions将两个数组作为参数，即值和结果，再加上一个分隔符字符。返回时，结果返回一个数组，该数组包含值中每个值组合的连接字符串。如果值包含值：2、3、4、5和6，则返回的字符串为：

Inx Combination
  0  
  1  2
  2  3
  3  2|3
  4  4
  5  2|4
  6  3|4
  7  2|3|4
  8  5
  9  2|5
 10  3|5
 11  2|3|5
 12  4|5
 13  2|4|5
 14  3|4|5
 15  2|3|4|5
 16  6
 17  2|6
 18  3|6
 19  2|3|6
 20  4|6
 21  2|4|6
 22  3|4|6
 23  2|3|4|6
 24  5|6
 25  2|5|6
 26  3|5|6
 27  2|3|5|6
 28  4|5|6
 29  2|4|5|6
 30  3|4|5|6
 31  2|3|4|5|6

我认为例程中有足够的注释来解释它是如何产生这个结果的

步骤3

宏循环返回的数组，拆分返回的字符串并访问该组合的每一行

我希望这一切都有意义。如果有必要的话，带着问题回来，但是你能自己破译我的代码越多，你理解它的速度就越快

代码

应将其替换为：

Dim InxRMax As Long              ' Maximum used entry in array Result
Dim InxVRCrnt As Long            ' Working index into arrays Value and InxResultCrnt

数据类型Long指定一个32位有符号整数，它将解决直接的问题

注意：在32位或64位计算机上不应使用数据类型Integer，因为16位Integer需要特殊的慢速处理

下表显示了隐藏的问题：

                                Duration
Number of        Number of      of macro
Keys/Values    combinations    in seconds
 5                       32       0.17
10                    1,024       0.24
15                   32,768       3.86
16                   65,536       8.02
17                  131,072      16.95
18                  262,144      33.04
19                  524,288      67.82
20                1,048,576     142.82
25               33,554,432 
30            1,073,741,824 
31            2,147,483,648 

N个值的组合数为2^N。我的宏正在生成每个可能的组合，并将其作为字符串存储在数组中。对于15个值，该数组有32768个条目，比16位有符号整数的最大值多一个

我将InxRMax的数据类型更正为Long，并为不同数量的值计时宏。您可以看到，每增加一个值，持续时间大约会增加一倍。我不愿意用21个或更多的值来测试maco。如果我尝试了31个值并等待它完成，宏将再次失败

如果这是一次性练习，并且您有20个以上的值，则此方法可能仍然适用，因为您可以让宏保持运行状态，并在6、12、24或48分钟内执行其他操作。如果您有多个值，这种方法将不合适 您希望针对不同的值集重复运行宏。

第二个答案

我的第一个答案是，我相信，这是一个尽可能简单的解决方案：

这些步骤是完全分开的，这样更容易编码和理解。 大部分工作都是在我以前使用过的常规工作中进行的，毫无疑问，我会再次使用。 对于少量项目具有可接受的持续时间。 不受正值和负值的影响。 这个答案使用了不同的方法。这些步骤并不是分开的，这使得它们更加复杂，我怀疑这段代码将来是否有用处。这个方法会受到负数的影响，但我已经对这个问题进行了编码。最大的优点是持续时间大大缩短

我不相信这是Nuclearman引用的算法的实现。显然，该算法要求所有数字都是正数，并且每个元素都有一个排序；对于我的方法来说，这两个都不正确

宏的持续时间取决于值的范围，我缺乏确定持续时间预期上限值的数学技能。下表给出了指示性持续时间：

                           Duration of    Duration of    Number of
Number of    Number of      approach 1     approach 2    combinations
Keys/Values  combinations   in seconds     in seconds    tested
 1                    2            
 2                    4            
 3                    8            
 4                   16            
 5                   32           0.17           0.20         29
 6                   64            
 7                  128            
 8                  256            
 9                  512            
10                1,024           0.24           0.27        100
11                2,048            
12                4,096            
13                8,192            
14               16,384            
15               32,768           3.86           0.41     10,021
16               65,536           8.02           0.64     18,586
17              131,072          16.95           0.70     21,483
18              262,144          33.04           0.76     24,492
19              524,288          67.82           0.83     28,603
20            1,048,576         142.82           0.99     34,364
21            2,097,152            
22            4,194,304            
23            8,388,608            
24           16,777,216            
25           33,554,432            
26           67,108,864                          8.97    315,766

方法1的持续时间随着每一个额外的项目而加倍，因为它测试每一个可能的组合。方法2更复杂，项目数量较少时速度较慢，但仅通过测试一小部分可能的组合，它是项目数量较多时速度较快的方法。我在方法1和方法2测试中使用了相同的数据，因此我认为这表明了您可能期望的持续时间

方法2中的第一步是将KeyValue表按值升序排序

下一步是将KeyValue表从工作表导入数组。方法1可以做到这一点，但该方法完全是为了简单，而方法2则是为了减少持续时间

假设组合是从Value1到ValueN的选择。如果将ValueN+1添加到组合中会使总数超过最大值，则添加任何后续值也会使总数超过最大值，因为所有后续值都大于ValueN+1。因此，对该组合的任何添加都将超过最大总数，无需考虑扩展

我对Approach 2宏中的文档更加小心。我相信我已经详细解释了该方法及其实施。但是，如果有必要，请带着问题回来

Option Explicit

  ' * I have a system for allocating names to my constants and variables.
  '   I can look at macros I wrote years ago and immediately know the
  '   purpose of the variables. This is a real help if I need to enhance
  '   an old macro.
  ' * If you do not like my system, develop your own.
  ' * My names are a sequence of words each of which reduces the scope
  '   of the variable.
  ' * Typically, the first word identified the purpose:
  '     Inx  index into a 1D array
  '     Col  a column of a worksheet or a 2D array
  '     Row  a row of a worksheet or a 2D array
  '     Wsht something to do with a worksheet
  ' * If I have more than worksheet, I will have a keyword to identify
  '   which worksheet a variable is used for:
  '     ColSrc   a column of the source worksheet
  '     RowRslt  a row of a results worksheet
  '     ColKV    a column of the KeyValue array

  ' Although most constants are only used by one routine, some are used by
  ' more than one. I have defined all as global so all constants are together.
  ' ==========================================================================

  ' * Changes values if the minimum and maximum values are moved.
  ' * The code assumes both values are in the Source worksheet.
  Const CellSrcMin As String = "C3"
  Const CellSrcMax As String = "D3"

  ' * The leftmost column will always be 1 no matter what
  '   columns the KeyValue table occupies in the worksheet
  ' * Reverse values if the columns are swapped
  Const ColKVKey As Long = 1
  Const ColKVValue As Long = 2

  ' * Reverse values if the columns are swapped
  Const ColRsltValue As String = "A"
  Const ColRsltExpnKey As String = "B"
  Const ColRsltExpnValue As String = "C"

  ' * Change both of these constants if the KeyValue table
  '   does not start in column A of the worksheet
  Const ColSrcKVFirst As String = "A"
  Const ColSrcKVLast As String = "B"

  ' * Change both of these constants if the KeyValue table
  '   does not start in column A of the worksheet
  ' * Reverse values if the columns are swapped
  Const ColSrcKVKey As String = "A"
  Const ColSrcKVValue As String = "B"

  ' Increase value if a second or third header row is added
  ' Reduce value to 1 if there is no header row
  Const RowSrcDataFirst As Long = 2

  ' Change values to match worksheet names
  Const WshtRsltName As String = "Result"
  Const WshSrcName As String = "Source"

  ' Variables used by more than one routine
  ' =======================================

  ' The KeyValue table will be loaded from the source worksheet to this
  ' variant as a 2D array
  Dim KeyValue As Variant

  ' Row in results worksheet to which the next result will be written
  Dim RowRsltNext As Long

Sub Control2()

  ' If one of the tests of the last entry in the pending arrays
  ' indicate that entry should be deleted, set to True.
  Dim DeleteEntry As Boolean

  ' The current last used entry in the pending arrays
  Dim InxPendingCrntMax As Long

  ' Number of combinations tested
  Dim NumTested As Long

  ' * The Pending arrays hold information about combinations that are pending;
  '   that is, combinations that have not been accepted as having an in-range
  '   total and have not been rejected as having an above maximum total.
  ' * The value of an entry in PendingWhichKeys might be "++-+". This means
  '   that this combination contains the first, second and fourth values but not
  '   the third. The corresponding entry in PendingTotal will contain the total
  '   of the first, second and fourth values.
  Dim PendingWhichKeys() As String
  Dim PendingTotal() As Double

  ' * Rows within KeyValue.
  ' * RowKVFirst is the control variable for the outer For-Loop. A value of N
  '   means this repeat considers combinations that start with the Nth value.
  ' * RowKVCrnt is used in the inner Do-Loop. It is set to the number of the
  '   next row to be considered for addition to a combination.
  Dim RowKVFirst As Long
  Dim RowKVCrnt As Long

  ' The last row of the KeyValue table within the source worksheet
  Dim RowSrcDataLast As Long

  ' Used to calculate the duration of a run.  Set by Timer to the number of
  ' seconds since midnight. The value includes fractions of a second but I
  ' cannot find any documentation that specifies how accurate the time is.
  ' I suspect it depends on the clock speed.  Anyway, with OS and other
  ' background routines running at any time, no timings are that accurate.
  Dim TimeStart As Double

  ' The minimum and maximum values are copied from the
  ' source worksheet to these variables.
  Dim TotalMax As Double
  Dim TotalMin As Double

  TimeStart = Timer

  With Worksheets(WshSrcName)

    ' Find last row in KeyValue table
    RowSrcDataLast = .Cells(Rows.Count, ColSrcKVKey).End(xlUp).Row

    ' Sort KeyValue table within worksheet by value
    .Range(.Cells(RowSrcDataFirst, ColSrcKVKey), _
           .Cells(RowSrcDataLast, ColSrcKVValue)) _
       .Sort Key1:=.Range(ColSrcKVValue & RowSrcDataFirst), _
             Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
             MatchCase:=False, Orientation:=xlTopToBottom, _
             DataOption1:=xlSortNormal

    ' KeyValue is of data type Variant (meaning it can hold anything).
    ' This statement loads all the data from a range and places it in KeyValue
    ' as a 2D array. The first dimension will be for rows and the second for
    ' columns. Both lower bounds will be 1 regardless of where the range was
    ' located.
    KeyValue = .Range(.Cells(RowSrcDataFirst, ColSrcKVFirst), _
                     .Cells(RowSrcDataLast, ColSrcKVLast)).Value

    ' Get the minimum and maximum required values
    TotalMin = .Range(CellSrcMin).Value
    TotalMax = .Range(CellSrcMax).Value

  End With

  ' Initialise result worksheet
  With Worksheets(WshtRsltName)
    .Cells.EntireRow.Delete
    With .Range("A1")
      .Value = "Total"
      .HorizontalAlignment = xlRight
    End With
    .Range("B1").Value = "Key Expn"
    .Range("C1").Value = "Value Expn"
    .Range("A1:C1").Font.Bold = True
    ' This value will be overwritten if any combination gives an acceptable value
    .Range("A2").Value = "No combination gives a total in the range " & _
                         TotalMin & " to " & TotalMax
  End With
  RowRsltNext = 2

  ' The maximum pending entries is the number of rows in the KeyValue table
  ReDim PendingWhichKeys(1 To UBound(KeyValue, 1))
  ReDim PendingTotal(1 To UBound(KeyValue, 1))

  NumTested = 0

  ' Each repeat of this loop considers the combinations that
  ' start with the KeyValue from RowKVFirst.
  For RowKVFirst = 1 To UBound(KeyValue, 1)

    If KeyValue(RowKVFirst, ColKVValue) > TotalMax Then
      ' The value of the first entry is above the maximum acceptable value.
      ' Any further values will be even larger so there are no more combinations
      ' that could be acceptable
      Exit For
    End If

    ' Create entries in the pending arrays for the shortest combination
    ' being considered during this repeat of the outer loop.
    PendingWhichKeys(1) = "+"
    PendingTotal(1) = KeyValue(RowKVFirst, ColKVValue)
    InxPendingCrntMax = 1        ' The last currently used entry
    NumTested = NumTested + 1

    Do While InxPendingCrntMax > 0
      ' Examine last entry in pending arrays:
      '  * if total is within range, add entry to results worksheet
      '  * if adding the value of the next KeyValue would cause the total
      '    to exceed the maximum, delete entry from pending arrays
      '  * if the last row of the KeyValue table has been considered for
      '    inclusion in the combination, delete entry from pending arrays
      '  * if the entry is not to be deleted:
      '      * create new entry in pending arrays.
      '      * copy the previous last entry to this new entry but with an
      '        extra "-" at the end of the PendingWhichKeys entry
      '      * Add "+" to end of PendingWhichKeys entry and add appropriate
      '        value to PendingTotal entry

      If PendingTotal(InxPendingCrntMax) >= TotalMin And _
         PendingTotal(InxPendingCrntMax) <= TotalMax Then
        ' This is an acceptable value
        If Right(PendingWhichKeys(InxPendingCrntMax), 1) = "+" Then
          ' This combination has not been output before
          Call OutputResult(RowKVFirst, PendingWhichKeys(InxPendingCrntMax), _
               PendingTotal(InxPendingCrntMax))
        End If
      End If

      DeleteEntry = False
      ' Identify next row of KeyValue that could be added to combination
      RowKVCrnt = RowKVFirst + Len(PendingWhichKeys(InxPendingCrntMax))
      If RowKVCrnt > UBound(KeyValue, 1) Then
        ' All rows have been considered for addition to this combination
        DeleteEntry = True
      ElseIf PendingTotal(InxPendingCrntMax) + KeyValue(RowKVCrnt, ColKVValue) _
                                                          > TotalMax Then
        ' Adding another value to this combination would cause it to exceed
        ' the maximum value.  Because of the sort, any other values will be
        ' larger than the current value so no extension to this combination
        ' need be considered.
        DeleteEntry = True
      End If

      If DeleteEntry Then
        ' Abandon this combination
        InxPendingCrntMax = InxPendingCrntMax - 1
      Else
        ' Extend this combination
        ' Create new combination based on non-addition of current row
        ' to current combination
        PendingWhichKeys(InxPendingCrntMax + 1) = _
                                            PendingWhichKeys(InxPendingCrntMax) & "-"
        PendingTotal(InxPendingCrntMax + 1) = PendingTotal(InxPendingCrntMax)
        ' Add current row to existing combination
        PendingWhichKeys(InxPendingCrntMax) = _
                                            PendingWhichKeys(InxPendingCrntMax) & "+"
        PendingTotal(InxPendingCrntMax) = PendingTotal(InxPendingCrntMax) + _
                                                      KeyValue(RowKVCrnt, ColKVValue)
        InxPendingCrntMax = InxPendingCrntMax + 1
        ' I consider both the new and the amended entries as new tests
        NumTested = NumTested + 2
      End If
    Loop
  Next

  With Worksheets(WshtRsltName)
    .Columns("A:C").AutoFit
  End With

  Debug.Print "Number keys " & UBound(KeyValue, 1)
  Debug.Print "Number tested " & NumTested
  Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.00")

End Sub
Sub OutputResult(ByVal RowKVFirst As Long, ByVal WhichKeys As String, _
                 ByVal Total As Double)

  ' Output a result to result worksheet

  ' Global variables:
  '  * KeyValue
  '  * RowRsltNext

  ' Parameters:
  '  * RowKVFirst  Identifies the first row in KeyValue being considered
  '                currently. KeyValues in rows 1 to RowKVFirst-1 are not
  '                within the current combination.
  '  * WhichKeys   Identifies which KeyValues are present in the current
  '                combination.  If the value is "++-+" then:
  '                 * Row RowKVFirst   selected
  '                 * Row RowKVFirst+1 selected
  '                 * Row RowKVFirst+2 not selected
  '                 * Row RowKVFirst+3 selected
  '                 * Row RowKVFirst+4, if present, and any following rows
  '                   not selected
  '  * Total       The total value of the current combination.

  Dim ExpnKey As String
  Dim ExpnValue As String
  Dim PosWhichKeys As Long
  Dim RowKVCrnt As Long

  With Worksheets(WshtRsltName)
    ' Output total for combination
    .Cells(RowRsltNext, ColRsltValue) = Total
    ' Create key string
    ' Get Key and Value from first row within combination
    ExpnKey = KeyValue(RowKVFirst, ColKVKey)
    ExpnValue = KeyValue(RowKVFirst, ColKVValue)
    ' Add keys and values from any other rows
    For PosWhichKeys = 2 To Len(WhichKeys)
      If Mid(WhichKeys, PosWhichKeys, 1) = "+" Then
        ' This rows is within combination
        RowKVCrnt = RowKVFirst + PosWhichKeys - 1
        ExpnKey = ExpnKey & "+" & KeyValue(RowKVCrnt, ColKVKey)
        ExpnValue = ExpnValue & "+" & KeyValue(RowKVCrnt, ColKVValue)
      End If
    Next
    .Cells(RowRsltNext, ColRsltExpnKey) = ExpnKey
    .Cells(RowRsltNext, ColRsltExpnValue) = ExpnValue
    RowRsltNext = RowRsltNext + 1
  End With

End Sub

第三种方法

方法1测试了所有可能的组合。这种方法易于编码，如果集合中没有太多的项目，就足够了。您已将集合中的项目数量增加了很多，因此此方法不可行

方法2和3都确定了盲道，以减少测试的组合数量。这两种方法都将集合按升序排序，但使用不同的技术来识别死巷。一旦我想到了方法3，我相信它会比方法2更好。然而，如果有一种技术可以证明方法3是更好的方法，而不进行测试，那么我就没有足够的智慧去了解它

解决方案3中与方法无关的更改

本节介绍了一些更改，这些更改是参数化宏的更好方法，也是显示结果的更好方法，如果我早些时候想到它们，这些更改将包含在解决方案1和2中

我发现有一系列的目标，X±a，其中a很小，但键集较小。如果做得太小，我就找不到火柴了。如果做得太大，我会得到过多的匹配

我用单个目标替换了一个范围，并引入了一个新参数：结果表中的行数RowRsltArrMax。这意味着，该例程不必猜测将给我提供可接受数量的结果的范围，而是为我提供最佳RowRsltArrMax结果，或者在找到目标结果上的RowRsltArrMax时停止

拥有固定数量的结果可以更容易地管理它们。我没有将每个范围内的结果直接写入工作表，而是准备了一个数组来写入工作表。第一个RowRsltArrMax结果将写入阵列，而不管其是否符合目标。在此之后，任何新的结果都会覆盖以前的最差结果（如果更好）。这里的“更好”指的是一个更接近目标的总数

该例程现在在状态栏中显示一条消息：

Current results; closest to furthest from target: N to M

当我第一次创建第三个解决方案时，我将结果数组写入工作表，并在每次更新结果数组时保存工作簿。我知道这会减慢宏的速度，但我认为在出现问题时，将最好的可用结果存储在光盘上是值得的。然而，我遇到了一个问题。有时宏会在ThisWorkbook.Save上停止。 以前版本的工作簿已正确保存在光盘上，但VBA或键盘无法保存内存中的版本。我猜这与工作簿的保存频率有关，并更改了例程，以便在找到比已保存的结果更好的结果时，将结果数组写入工作表，并每分钟保存一次工作簿。此更改似乎消除了保存问题，并显示每次保存新结果时保存工作簿会显著降低宏的速度，如以下结果所示：

        ---- Duration (m:ss)-----
RowMax  Save every    Save every
          result    minute or two
    10      9:43       0:57
    20     20:08       1:57 
    30                 3:34
    40                 5:35
   100                16:56 
   363                67:27

这些计时使用包含43行的KeyValue表，随机值介于−300000和1000000，目标为653441。上表最后一行的值是通过将RowRsltArrMax设置得很高而创建的，这样可以找到与目标求和的每个组合

解决方案3

此图显示KeyValue表的顶部和目标值

此图显示了RowRsltArrMax=10运行后的结果工作表。公式栏显示单元格A2=单元格D2，但A2值的开头为=，因此Excel将其视为公式，而D2的开头为'，因此Excel将其视为字符串

我发现描述解决方案3背后的技术并不容易。概括而言，该技术是：

通过为每个正值创建一个组合，为挂起表设定种子。不为具有负值的键创建种子，以避免生成多个相同的组合， 循环重复步骤3，直到结果表中满是目标结果或挂起的表为空。 从挂起的表中删除底行。考虑将其添加到结果表中，如步骤4所述。尝试从中生成更多组合，如步骤5所述。 从挂起表中删除的每一行都将添加到结果表中，直到其满为止。一旦结果表满了，每个新组合的总数将与迄今为止最差的总数进行比较。如果新总数更好，新行将覆盖迄今为止最差的行。 如果新组合的总数小于目标总数，则为大于组合中任何现有正值的每个正值生成一个新组合。如果新组合的总和大于目标总和，则为大于组合中任何现有负值的每个负值生成一个新组合。“较大”限制可避免多次生成相同的组合。 宏控制3包含的代码将在第一个循环之前和每个循环结束时将挂起表和结果表的内容输出到工作表“Diag”。此代码当前已注释掉，请参见“开始”语句，因为它只应用于小的KeyValue表。如果删除并使用一个小集合和一个小结果表运行宏，您将在工作表“Diag”中生成诊断信息，您可以向下查看宏在每一步中的作用

下面的图表可能会有所帮助。对于这个图，我将RowRsltArrMax设置为5，并创建了一个6行的KeyValue表。排序后，将KeyValue表加载到数组中，以便于访问：

Index  Key     Value
1      AB   -205,082
2      AF    -74,308
3      AC    293,704
4      AE    651,560
5      AA    761,311
6      AD    852,254

挂起数组有两列：Expn和Diff。Expn包含表示组合的字符串，而Diff包含组合的总值与目标值之间的差值。挂起数组的种子是KeyValue表中每个正值一行。下图的左栏表示种子。每个框的顶行包含一个组合，第二行包含该组合的总值，第三行显示目标总值减去总值

挂起的数组仅使用正值作为种子；这是确保不能多次生成相同组合的三个限制之一。此特定限制意味着不能生成仅包含负值的组合。仅当目标值为负值或低正值时才会出现此问题。这种技术可以扩展到允许这样的目标值，但我认为这是没有必要的

Option Explicit

  ' * I have a system for allocating names to my constants and variables.
  '   I can look at macros I wrote years ago and immediately know the
  '   purpose of the variables. This is a real help if I need to enhance
  '   an old macro.
  ' * If you do not like my system, develop your own.
  ' * My names are a sequence of words each of which reduces the scope
  '   of the variable.
  ' * Typically, the first word identified the purpose:
  '     Inx  index into a 1D array
  '     Col  a column of a worksheet or a 2D array
  '     Row  a row of a worksheet or a 2D array
  '     Wsht something to do with a worksheet
  ' * If I have more than worksheet, I will have a keyword to identify
  '   which worksheet a variable is used for:
  '     ColSrc   a column of the source worksheet
  '     RowRslt  a row of a results worksheet
  '     ColKV    a column of the KeyValue array

  ' Although most constants are only used by one routine, some are used by
  ' more than one. I have defined all as global so all constants are together.
  ' ==========================================================================

  ' * Changes values if the minimum and maximum values are moved.
  ' * The code assumes both values are in the Source worksheet.
  Const CellSrcMin As String = "C3"
  Const CellSrcMax As String = "D3"

  ' * The leftmost column will always be 1 no matter what
  '   columns the KeyValue table occupies in the worksheet
  ' * Reverse values if the columns are swapped
  Const ColKVKey As Long = 1
  Const ColKVValue As Long = 2

  ' * Reverse values if the columns are swapped
  Const ColRsltValue As String = "A"
  Const ColRsltExpnKey As String = "B"
  Const ColRsltExpnValue As String = "C"

  ' * Change both of these constants if the KeyValue table
  '   does not start in column A of the worksheet
  Const ColSrcKVFirst As String = "A"
  Const ColSrcKVLast As String = "B"

  ' * Change both of these constants if the KeyValue table
  '   does not start in column A of the worksheet
  ' * Reverse values if the columns are swapped
  Const ColSrcKVKey As String = "A"
  Const ColSrcKVValue As String = "B"

  ' Increase value if a second or third header row is added
  ' Reduce value to 1 if there is no header row
  Const RowSrcDataFirst As Long = 2

  ' Change values to match worksheet names
  Const WshtRsltName As String = "Result"
  Const WshSrcName As String = "Source"

  ' Variables used by more than one routine
  ' =======================================

  ' The KeyValue table will be loaded from the source worksheet to this
  ' variant as a 2D array
  Dim KeyValue As Variant

  ' Row in results worksheet to which the next result will be written
  Dim RowRsltNext As Long

Sub Control2()

  ' If one of the tests of the last entry in the pending arrays
  ' indicate that entry should be deleted, set to True.
  Dim DeleteEntry As Boolean

  ' The current last used entry in the pending arrays
  Dim InxPendingCrntMax As Long

  ' Number of combinations tested
  Dim NumTested As Long

  ' * The Pending arrays hold information about combinations that are pending;
  '   that is, combinations that have not been accepted as having an in-range
  '   total and have not been rejected as having an above maximum total.
  ' * The value of an entry in PendingWhichKeys might be "++-+". This means
  '   that this combination contains the first, second and fourth values but not
  '   the third. The corresponding entry in PendingTotal will contain the total
  '   of the first, second and fourth values.
  Dim PendingWhichKeys() As String
  Dim PendingTotal() As Double

  ' * Rows within KeyValue.
  ' * RowKVFirst is the control variable for the outer For-Loop. A value of N
  '   means this repeat considers combinations that start with the Nth value.
  ' * RowKVCrnt is used in the inner Do-Loop. It is set to the number of the
  '   next row to be considered for addition to a combination.
  Dim RowKVFirst As Long
  Dim RowKVCrnt As Long

  ' The last row of the KeyValue table within the source worksheet
  Dim RowSrcDataLast As Long

  ' Used to calculate the duration of a run.  Set by Timer to the number of
  ' seconds since midnight. The value includes fractions of a second but I
  ' cannot find any documentation that specifies how accurate the time is.
  ' I suspect it depends on the clock speed.  Anyway, with OS and other
  ' background routines running at any time, no timings are that accurate.
  Dim TimeStart As Double

  ' The minimum and maximum values are copied from the
  ' source worksheet to these variables.
  Dim TotalMax As Double
  Dim TotalMin As Double

  TimeStart = Timer

  With Worksheets(WshSrcName)

    ' Find last row in KeyValue table
    RowSrcDataLast = .Cells(Rows.Count, ColSrcKVKey).End(xlUp).Row

    ' Sort KeyValue table within worksheet by value
    .Range(.Cells(RowSrcDataFirst, ColSrcKVKey), _
           .Cells(RowSrcDataLast, ColSrcKVValue)) _
       .Sort Key1:=.Range(ColSrcKVValue & RowSrcDataFirst), _
             Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
             MatchCase:=False, Orientation:=xlTopToBottom, _
             DataOption1:=xlSortNormal

    ' KeyValue is of data type Variant (meaning it can hold anything).
    ' This statement loads all the data from a range and places it in KeyValue
    ' as a 2D array. The first dimension will be for rows and the second for
    ' columns. Both lower bounds will be 1 regardless of where the range was
    ' located.
    KeyValue = .Range(.Cells(RowSrcDataFirst, ColSrcKVFirst), _
                     .Cells(RowSrcDataLast, ColSrcKVLast)).Value

    ' Get the minimum and maximum required values
    TotalMin = .Range(CellSrcMin).Value
    TotalMax = .Range(CellSrcMax).Value

  End With

  ' Initialise result worksheet
  With Worksheets(WshtRsltName)
    .Cells.EntireRow.Delete
    With .Range("A1")
      .Value = "Total"
      .HorizontalAlignment = xlRight
    End With
    .Range("B1").Value = "Key Expn"
    .Range("C1").Value = "Value Expn"
    .Range("A1:C1").Font.Bold = True
    ' This value will be overwritten if any combination gives an acceptable value
    .Range("A2").Value = "No combination gives a total in the range " & _
                         TotalMin & " to " & TotalMax
  End With
  RowRsltNext = 2

  ' The maximum pending entries is the number of rows in the KeyValue table
  ReDim PendingWhichKeys(1 To UBound(KeyValue, 1))
  ReDim PendingTotal(1 To UBound(KeyValue, 1))

  NumTested = 0

  ' Each repeat of this loop considers the combinations that
  ' start with the KeyValue from RowKVFirst.
  For RowKVFirst = 1 To UBound(KeyValue, 1)

    If KeyValue(RowKVFirst, ColKVValue) > TotalMax Then
      ' The value of the first entry is above the maximum acceptable value.
      ' Any further values will be even larger so there are no more combinations
      ' that could be acceptable
      Exit For
    End If

    ' Create entries in the pending arrays for the shortest combination
    ' being considered during this repeat of the outer loop.
    PendingWhichKeys(1) = "+"
    PendingTotal(1) = KeyValue(RowKVFirst, ColKVValue)
    InxPendingCrntMax = 1        ' The last currently used entry
    NumTested = NumTested + 1

    Do While InxPendingCrntMax > 0
      ' Examine last entry in pending arrays:
      '  * if total is within range, add entry to results worksheet
      '  * if adding the value of the next KeyValue would cause the total
      '    to exceed the maximum, delete entry from pending arrays
      '  * if the last row of the KeyValue table has been considered for
      '    inclusion in the combination, delete entry from pending arrays
      '  * if the entry is not to be deleted:
      '      * create new entry in pending arrays.
      '      * copy the previous last entry to this new entry but with an
      '        extra "-" at the end of the PendingWhichKeys entry
      '      * Add "+" to end of PendingWhichKeys entry and add appropriate
      '        value to PendingTotal entry

      If PendingTotal(InxPendingCrntMax) >= TotalMin And _
         PendingTotal(InxPendingCrntMax) <= TotalMax Then
        ' This is an acceptable value
        If Right(PendingWhichKeys(InxPendingCrntMax), 1) = "+" Then
          ' This combination has not been output before
          Call OutputResult(RowKVFirst, PendingWhichKeys(InxPendingCrntMax), _
               PendingTotal(InxPendingCrntMax))
        End If
      End If

      DeleteEntry = False
      ' Identify next row of KeyValue that could be added to combination
      RowKVCrnt = RowKVFirst + Len(PendingWhichKeys(InxPendingCrntMax))
      If RowKVCrnt > UBound(KeyValue, 1) Then
        ' All rows have been considered for addition to this combination
        DeleteEntry = True
      ElseIf PendingTotal(InxPendingCrntMax) + KeyValue(RowKVCrnt, ColKVValue) _
                                                          > TotalMax Then
        ' Adding another value to this combination would cause it to exceed
        ' the maximum value.  Because of the sort, any other values will be
        ' larger than the current value so no extension to this combination
        ' need be considered.
        DeleteEntry = True
      End If

      If DeleteEntry Then
        ' Abandon this combination
        InxPendingCrntMax = InxPendingCrntMax - 1
      Else
        ' Extend this combination
        ' Create new combination based on non-addition of current row
        ' to current combination
        PendingWhichKeys(InxPendingCrntMax + 1) = _
                                            PendingWhichKeys(InxPendingCrntMax) & "-"
        PendingTotal(InxPendingCrntMax + 1) = PendingTotal(InxPendingCrntMax)
        ' Add current row to existing combination
        PendingWhichKeys(InxPendingCrntMax) = _
                                            PendingWhichKeys(InxPendingCrntMax) & "+"
        PendingTotal(InxPendingCrntMax) = PendingTotal(InxPendingCrntMax) + _
                                                      KeyValue(RowKVCrnt, ColKVValue)
        InxPendingCrntMax = InxPendingCrntMax + 1
        ' I consider both the new and the amended entries as new tests
        NumTested = NumTested + 2
      End If
    Loop
  Next

  With Worksheets(WshtRsltName)
    .Columns("A:C").AutoFit
  End With

  Debug.Print "Number keys " & UBound(KeyValue, 1)
  Debug.Print "Number tested " & NumTested
  Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.00")

End Sub
Sub OutputResult(ByVal RowKVFirst As Long, ByVal WhichKeys As String, _
                 ByVal Total As Double)

  ' Output a result to result worksheet

  ' Global variables:
  '  * KeyValue
  '  * RowRsltNext

  ' Parameters:
  '  * RowKVFirst  Identifies the first row in KeyValue being considered
  '                currently. KeyValues in rows 1 to RowKVFirst-1 are not
  '                within the current combination.
  '  * WhichKeys   Identifies which KeyValues are present in the current
  '                combination.  If the value is "++-+" then:
  '                 * Row RowKVFirst   selected
  '                 * Row RowKVFirst+1 selected
  '                 * Row RowKVFirst+2 not selected
  '                 * Row RowKVFirst+3 selected
  '                 * Row RowKVFirst+4, if present, and any following rows
  '                   not selected
  '  * Total       The total value of the current combination.

  Dim ExpnKey As String
  Dim ExpnValue As String
  Dim PosWhichKeys As Long
  Dim RowKVCrnt As Long

  With Worksheets(WshtRsltName)
    ' Output total for combination
    .Cells(RowRsltNext, ColRsltValue) = Total
    ' Create key string
    ' Get Key and Value from first row within combination
    ExpnKey = KeyValue(RowKVFirst, ColKVKey)
    ExpnValue = KeyValue(RowKVFirst, ColKVValue)
    ' Add keys and values from any other rows
    For PosWhichKeys = 2 To Len(WhichKeys)
      If Mid(WhichKeys, PosWhichKeys, 1) = "+" Then
        ' This rows is within combination
        RowKVCrnt = RowKVFirst + PosWhichKeys - 1
        ExpnKey = ExpnKey & "+" & KeyValue(RowKVCrnt, ColKVKey)
        ExpnValue = ExpnValue & "+" & KeyValue(RowKVCrnt, ColKVValue)
      End If
    Next
    .Cells(RowRsltNext, ColRsltExpnKey) = ExpnKey
    .Cells(RowRsltNext, ColRsltExpnValue) = ExpnValue
    RowRsltNext = RowRsltNext + 1
  End With

End Sub

例程循环，直到挂起的数组为空。每次重复都会删除挂起表的底行，作为可能令人满意的组合，然后将行添加到挂起表中，以便从刚刚删除的组合中生成可能更好的组合

考虑图中左下角的框。键AD的值为852254，比目标值多198813。我们希望这不是找到的最佳组合，但它将被放置在结果数组中，直到找到更好的组合

由于此组合的总值高于目标值，因此只有添加负值才能得到更好的组合。由于组合不包含任何负值，因此一个梳 为每个负值创建并添加到挂起数组。这些新的组合显示在图表的右下角

这两个新组合将依次作为结果数组中的第二个和第三个条目。然而，这些组合中的任何一个都不能成为更好组合的基础

AB+AD总共比目标低6269，因此我们必须添加正值以获得更好的组合。但是，此组合已包含AD，它是KeyValue表中的最低正值。确保每个组合只有一个副本的第二个限制是，只能添加低于任何现有正值的正值。AB+AA+AD组合将在以后通过向AB+AA添加AD来创建

AF+AD总共比目标高124505，因此我们必须添加负值以获得更好的组合。但是，此组合已包含AF，它是KeyValue表中的最低负值。确保每个组合只有一个副本的第三个限制是，只能添加低于任何现有负值的负值

下一个可能的结果是AA。该图显示将从中生成AF+AA和AB+AA。不能从AF+AA生成进一步的组合，但AB+AA+AD可以从AB+AA生成。AB+AA+AD不能产生进一步的组合

如果要探索AE和AC生成的组合，请创建一个KeyValue表以匹配我的，并在诊断代码激活的情况下运行宏

我无法设计出一种技术来检测比这更少的组合。我或多或少地相信，潜在的好组合不会被忽视。由于它发现了如此多具有较大集合的目标上的组合，如果忽略了其中一些组合，这可能并不重要

任何此类技术的秘密都是在尽可能早的时候正确识别死巷。我已经确定了两个。也许你能找到一个比我的更好的。祝你好运

由于答案大小的字符限制，我不得不单独发布方法3的代码。

方法3的代码-第1部分

格式化的代码太大，一个答案无法回答。将第1部分和第2部分加载到各自的模块中

Option Explicit
  ' * Address of cell holding target value
  ' * Changes value if the target value is moved.
  ' * The code assumes both values are in the Source worksheet.
  Const CellSrcTgt As String = "C2"

  ' * Column numbers within KeyValue table once
  ' * The leftmost column will always be 1 no matter what
  '   columns the KeyValue table occupies in the worksheet
  ' * Reverse values if the columns are swapped
  Const ColKVKey As Long = 1
  Const ColKVValue As Long = 2

  ' * Change values if the columns are swapped.
  ' * Increase ColRsltMax if a new column is added
  ' * Providing the table in the worksheet starts in column 1, column numbers
  '   are the same in the array and the worksheet.  If the worksheet table
  '   does not start in column 1, two sets of column numbers constants will be
  '   required and all code referencing these constants will require review.
  Const ColRsltTotal As Long = 1
  Const ColRsltDiffAbs As Long = 2
  Const ColRsltExpnKey As Long = 3
  Const ColRsltExpnValue As Long = 4
  Const ColRsltMax As Long = 4

  ' These specify the columns with the Pending array so the code is
  ' self-documenting.  The Pending array is internal to this set of routine
  ' so there is no need to change theses values
  Const ColPendExpn As Long = 1
  Const ColPendDiff As Long = 2
  Const ColPendMax As Long = 2

  ' * Change both of these constants if the KeyValue table
  '   does not start in column A of the worksheet
  Const ColSrcKVFirst As String = "A"
  Const ColSrcKVLast As String = "B"

  ' * Change both of these constants if the KeyValue table
  '   does not start in column A of the worksheet
  ' * Reverse values if the columns are swapped
  Const ColSrcKVKey As String = "A"
  Const ColSrcKVValue As String = "B"

  ' Defines the first row within the results worksheet of the range to which
  ' the Results array is written. Change if the number of header rows changes.
  Const RowRsltWshtDataFirst As Long = 2

  ' Increase value if a second or third header row is added
  ' Reduce value to 1 if there is no header row
  Const RowSrcDataFirst As Long = 2

  ' Change values to match your worksheet names
  Const WshtRsltName As String = "Result"
  Const WshSrcName As String = "Source"

  ' Variables used by more than one routine
  ' =======================================

  ' The KeyValue table will be loaded from the source worksheet to this
  ' variant as a 2D array
  Dim KeyValue As Variant

'#  ' Current row number for worksheet Diag
'#  Dim RowDiagCrnt As Long

Sub Control3()

  ' Find the combinations of items from the KeyValue tables whose total values
  ' are closest to the target total.

'#  Dim ExpnKeyCrnt As String
'#  Dim ExpnValueCrnt As String

  ' While duplicating a pending row, its contents are held in these variable
  Dim PendExpnCrnt As String
  Dim PendDiffCrnt As Long

  ' * The Pending array hold information about combinations that are pending;
  '   that is, combinations that are on target or might become on target after
  '   addition of further items to the combination.
  ' * The array is redimensioned as a 2D array with 50,000 rows and 2 columns.
  '   Choice of 50,000 as the number of rows is arbitrary; less might be
  '   adequate and more might be better.
  ' * Typically with 2D arrays the first dimension is for columns and the
  '   second for rows so the number of rows can be increased or decreased with
  '   "ReDim Preserve".  Arrays that are read from or are written to worksheets
  '   must have the columns and rows reversed.  Pending is both written to and
  '   read from the worksheet Sort.
  ' * Column 1 holds detains of the combination as a string of the form
  '   "--+-+". The string has one "-" or "+" for every entry in the KeyValue
  '   table. If the Nth character in the string is "+", the Nth entry in the
  '   KeyValue table is included in the combination.
  ' * Column 2 holds TargetValue - TotalOfCombination.
  Dim Pending() As Variant

  Dim PosExpn As Long

  ' * Potential results are accumulated in this array.
  ' * The number of rows is defined by RowArrRsltsMax.
  ' * Initially every possible combination is added at the bottom of this
  '   array. Once the array is full, a new combination overwrites the
  '   previously stored combination with the worst total if the new combination
  '   has a better total. In this context, a better total is closer to the
  '   target total than a worse one.
  ' * Traditionally 2D arrays have columns as the first dimension and rows as
  '   the second dimension.  Arrays to be written to a worksheet must have their
  '   dimensions the other way round. After each new result is added to this
  '   array, the array is written to the results rworksheet and the workbook
  '   saved. This slows the macro but means that if it is terminated with the
  '   Task Manager any results found are already saved to disc.
  Dim Result() As Variant

  Dim RowKVCrnt As Long           ' Current row within KeyValue
  Dim RowKVFirstPositive As Long  ' First row within KeyValue with a +ve value

  Dim RowPendCrnt As Long     ' The current row in Pending
  Dim RowPendCrntMax As Long  ' The current last used row in Pending
  Dim RowPendMaxMax As Long   ' The last ever used row in Pending

  ' Defines the maximum number of results that will be accumulated
  Const RowRsltArrMax As Long = 40

  ' Row in array Result to which the next result will be written providing
  ' RowArrRsltNext < RowArrRsltMax.  Once RowArrRsltNext = RowArrRsltMax,
  ' any new combination overwrites an existing row.
  Dim RowRsltArrNext As Long
  ' Control variable for For-Loop
  Dim RowRsltArrCrnt As Long

  ' The last row of the KeyValue table within the source worksheet
  Dim RowSrcDataLast As Long

  ' Used to calculate the duration of a run.  Set by Timer to the number of
  ' seconds since midnight. The value includes fractions of a second but I
  ' cannot find any documentation that specifies how accurate the time is.
  ' I suspect it depends on the clock speed.  Anyway, with OS and other
  ' background routines running at any time, no timings are that accurate.
  Dim TimeStart As Double

  Dim TotalNegative As Long   ' The total of all negative values
  Dim TotalPositive As Long   ' The total of all posative values
  Dim TotalTgt As Long        ' The target value is copied from the source
                              ' worksheet to this variable.
  TimeStart = Timer

  Application.DisplayStatusBar = True
  Application.StatusBar = "No results found so far"

  With Worksheets(WshSrcName)

    ' Find last row in KeyValue table
    RowSrcDataLast = .Cells(Rows.Count, ColSrcKVKey).End(xlUp).Row

    ' Sort KeyValue table within worksheet by value
    .Range(.Cells(RowSrcDataFirst, ColSrcKVKey), _
           .Cells(RowSrcDataLast, ColSrcKVValue)) _
       .Sort Key1:=.Range(ColSrcKVValue & RowSrcDataFirst), _
             Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
             MatchCase:=False, Orientation:=xlTopToBottom, _
             DataOption1:=xlSortNormal

    ' KeyValue is of data type Variant (meaning it can hold anything).
    ' This statement loads all the data from a range and places it in KeyValue
    ' as a 2D array. The first dimension will be for rows and the second for
    ' columns. Both lower bounds will be 1 regardless of where the range was
    ' located.
    KeyValue = .Range(.Cells(RowSrcDataFirst, ColSrcKVFirst), _
                     .Cells(RowSrcDataLast, ColSrcKVLast)).Value

    ' Get the target value
    TotalTgt = .Range(CellSrcTgt).Value

  End With

  ' Gather information about the KeyValue table
  TotalNegative = 0
  For RowKVCrnt = 1 To UBound(KeyValue, 1)
    If KeyValue(RowKVCrnt, ColKVValue) >= 0 Then
      ' Treat a value of zero as positive.  Arbitrary choice.
      Exit For
    End If
    TotalNegative = TotalNegative + KeyValue(RowKVCrnt, ColKVValue)
  Next
  RowKVFirstPositive = RowKVCrnt
  TotalPositive = 0
  For RowKVCrnt = RowKVCrnt To UBound(KeyValue, 1)
    TotalPositive = TotalPositive + KeyValue(RowKVCrnt, ColKVValue)
  Next

  ' Initialise result worksheet
  With Worksheets(WshtRsltName)
    .Cells.EntireRow.Delete
    With .Cells(1, ColRsltTotal)
      .Value = "Total"
      .HorizontalAlignment = xlRight
    End With
    With .Cells(1, ColRsltDiffAbs)
      .Value = "Abs diff"
      .HorizontalAlignment = xlRight
    End With
    .Cells(1, ColRsltExpnKey) = "Key Expn"
    .Cells(1, ColRsltExpnValue).Value = "Value Expn"
    .Range(.Cells(1, 1), .Cells(1, ColRsltMax)).Font.Bold = True
    .Columns(ColRsltTotal).NumberFormat = "#,##0"
    .Columns(ColRsltDiffAbs).NumberFormat = "#,##0"
    ' This value will be overwritten if any combination gives an acceptable value
    .Range("A2").Value = "No combinations found"
  End With
  RowRsltArrNext = 1

  ' The technique used does not require large amounts of memory for pending
  ' combinations.  During testing the maximum number of rows used was 312 with
  ' RowRsltArrMax = 400.
  ReDim Pending(1 To 1000, 1 To ColPendMax)
  ReDim Result(1 To RowRsltArrMax, 1 To ColRsltMax)

  ' Seed Pending with one combination for every row in the
  ' KeyValue table with a positive value
  RowPendCrntMax = 0
  For RowKVCrnt = RowKVFirstPositive To UBound(KeyValue, 1)
    RowPendCrntMax = RowPendCrntMax + 1
    Pending(RowPendCrntMax, ColPendExpn) = String(RowKVCrnt - 1, "-") & "+" & _
                                           String(UBound(KeyValue, 1) - RowKVCrnt, "-")
    Pending(RowPendCrntMax, ColPendDiff) = TotalTgt - KeyValue(RowKVCrnt, ColKVValue)
  Next
  RowPendMaxMax = RowPendCrntMax

'#  RowDiagCrnt = 1
'#  With Worksheets("Diag")
'#    .Cells.EntireRow.Delete
'#    .Cells.ClearFormats
'#    .Cells(RowDiagCrnt, 1).Value = "Pending"
'#    With .Cells(RowDiagCrnt, 2)
'#      .Value = "Index"
'#      .HorizontalAlignment = xlRight
'#    End With
'#    .Cells(RowDiagCrnt, 3).Value = "Expn"
'#    .Cells(RowDiagCrnt, 4).Value = "Key Expn"
'#    .Cells(RowDiagCrnt, 5).Value = "Value Expn"
'#    With .Cells(RowDiagCrnt, 6)
'#      .Value = "Total"
'#      .HorizontalAlignment = xlRight
'#    End With
'#    .Cells(RowDiagCrnt, 7).Value = "Diff"
'#    RowDiagCrnt = RowDiagCrnt + 1
'#    For RowPendCrnt = 1 To RowPendCrntMax
'#      .Cells(RowDiagCrnt, 2).Value = RowPendCrnt
'#      With .Cells(RowDiagCrnt, 3)
'#        .Value = Pending(RowPendCrnt, ColPendExpn)
'#        .Font.Name = "Courier New"
'#      End With
'#      Call GenExpn(Pending(RowPendCrnt, ColPendExpn), ExpnKeyCrnt, ExpnValueCrnt)
'#      .Cells(RowDiagCrnt, 4).Value = ExpnKeyCrnt
'#      .Cells(RowDiagCrnt, 5).Value = "'" & ExpnValueCrnt
'#      .Cells(RowDiagCrnt, 6).Value = "=" & ExpnValueCrnt
'#      With .Cells(RowDiagCrnt, 7)
'#        .Value = Format(Pending(RowPendCrnt, ColPendDiff), "#,##0")
'#      End With
'#      RowDiagCrnt = RowDiagCrnt + 1
'#    Next
'#  End With
'#  RowDiagCrnt = RowDiagCrnt + 1

  Do While RowPendCrntMax > 0

    ' This combination may be one of those with a total nearest the target
    If Not OutputRslt(Pending, RowPendCrntMax, Result, RowRsltArrNext) Then
      ' Result is full of results with a total equal to the target total.
      ' No point searching any more because there is no room for more results.
      Application.DisplayStatusBar = False
      Debug.Print "Max Pending=" & RowPendMaxMax
      Debug.Print "Duration (sss.ss): " & Format(Timer - TimeStart, "#,##0.00")
      TimeStart = Timer - TimeStart     ' Duration
      Debug.Print "Duration (m:ss): " & Format(TimeStart \ 60, "#,##0") & ":" & Format(TimeStart Mod 60, "00")
      Call MsgBox("Result worksheet is full of on-target results.", vbOKOnly)
      Exit Sub
    End If

    PendExpnCrnt = Pending(RowPendCrntMax, ColPendExpn)
    PendDiffCrnt = Pending(RowPendCrntMax, ColPendDiff)

    ' Remove this combination from the Pending array.
    ' New copies will be added if appropriate.
    RowPendCrntMax = RowPendCrntMax - 1

    Select Case PendDiffCrnt
      Case Is < 0
        ' * The current total for this row is above the target.
        ' * Create a new combination for every negative value that can be
        '   added.
        ' * Negative values can only be added after any existing negative
        '   values to avoid creating multiple copies of the same combination.
        ' * An expression is of the form "+--+--+" with the position of each
        '   "+" or "-" corresponding to a row in KeyValue
        For PosExpn = RowKVFirstPositive - 1 To 1 Step -1
          If Mid(PendExpnCrnt, PosExpn, 1) = "-" Then
            ' This negative value has not been added
            RowPendCrntMax = RowPendCrntMax + 1
            If PosExpn = 1 Then
              ' "+" replaces first "-"
              Pending(RowPendCrntMax, ColPendExpn) = "+" & Mid(PendExpnCrnt, 2)
            Else
              ' "+" replaces a "-" in the middle
              Pending(RowPendCrntMax, ColPendExpn) = _
                                         Mid(PendExpnCrnt, 1, PosExpn - 1) & _
                                         "+" & _
                                         Mid(PendExpnCrnt, PosExpn + 1)
            End If
            ' KeyValue(RowKVCrnt, ColKVValue) is negative so subtracting it
            ' will increase PendDiffCrnt.
            Pending(RowPendCrntMax, ColPendDiff) = _
                                PendDiffCrnt - KeyValue(PosExpn, ColKVValue)
          Else
            ' This negative value is already within the combination
            ' so no more negative value can be added
            Exit For
          End If
        Next
        If RowPendMaxMax < RowPendCrntMax Then
          RowPendMaxMax = RowPendCrntMax
        End If
      Case Is >= 0
        ' The current total for this row is equal to or below the target
        ' * Create a new combination for every positive value that can be
        '   added.
        ' * Positive values can only be added after any existing positive
        '   values to avoid creating multiple copies of the same combination.
        ' * An expression is of the form "+--+--+" with the position of each
        '   "+" or "-" corresponding to a row in KeyValue
        For PosExpn = UBound(KeyValue, 1) To RowKVFirstPositive Step -1
          If Mid(PendExpnCrnt, PosExpn, 1) = "-" Then
            ' This positive value has not been added
            RowPendCrntMax = RowPendCrntMax + 1
            If PosExpn = UBound(KeyValue, 1) Then
              ' "+" replaces final "-"
              Pending(RowPendCrntMax, ColPendExpn) = Mid(PendExpnCrnt, 1, Len(PendExpnCrnt) - 1) & "+"
            Else
              ' "+" replaces a "-" in the middle
              Pending(RowPendCrntMax, ColPendExpn) = _
                                         Mid(PendExpnCrnt, 1, PosExpn - 1) & _
                                         "+" & _
                                         Mid(PendExpnCrnt, PosExpn + 1)
            End If
            ' KeyValue(RowKVCrnt, ColKVValue) is positive so subtracting it
            ' will reduce PendDiffCrnt.
            Pending(RowPendCrntMax, ColPendDiff) = _
                                PendDiffCrnt - KeyValue(PosExpn, ColKVValue)
          Else
            ' This positive value is already within the combination
            ' so no more positive value can be added
            Exit For
          End If
        Next
        If RowPendMaxMax < RowPendCrntMax Then
          RowPendMaxMax = RowPendCrntMax
        End If
    End Select

'#    With Worksheets("Diag")
'#
'#      .Cells(RowDiagCrnt, 1).Value = "Result"
'#      With .Cells(RowDiagCrnt, 2)
'#        .Value = "Index"
'#        .HorizontalAlignment = xlRight
'#      End With
'#      With .Cells(RowDiagCrnt, 3)
'#        .Value = "Total"
'#        .HorizontalAlignment = xlRight
'#      End With
'#      With .Cells(RowDiagCrnt, 4)
'#        .Value = "Abs diff"
'#        .HorizontalAlignment = xlRight
'#      End With
'#      .Cells(RowDiagCrnt, 5).Value = "Key Expn"
'#      .Cells(RowDiagCrnt, 6).Value = "Value Expn"
'#      RowDiagCrnt = RowDiagCrnt + 1
'#      For RowRsltArrCrnt = 1 To UBound(Result, 1)
'#        If RowRsltArrCrnt < RowRsltArrNext Then
'#          .Cells(RowDiagCrnt, 2).Value = RowRsltArrCrnt
'#          With .Cells(RowDiagCrnt, 3)
'#            .Value = Result(RowRsltArrCrnt, ColRsltTotal)
'#            .NumberFormat = "#,##0"
'#          End With
'#          With .Cells(RowDiagCrnt, 4)
'#            .Value = Result(RowRsltArrCrnt, ColRsltDiffAbs)
'#            .NumberFormat = "#,##0"
'#          End With
'#          .Cells(RowDiagCrnt, 5).Value = Result(RowRsltArrCrnt, ColRsltExpnKey)
'#          .Cells(RowDiagCrnt, 6).Value = Result(RowRsltArrCrnt, ColRsltExpnValue)
'#        RowDiagCrnt = RowDiagCrnt + 1
'#        End If
'#      Next
'#
'#      .Cells(RowDiagCrnt, 1).Value = "Pending"
'#      With .Cells(RowDiagCrnt, 2)
'#        .Value = "Index"
'#        .HorizontalAlignment = xlRight
'#      End With
'#      .Cells(RowDiagCrnt, 3).Value = "Expn"
'#      .Cells(RowDiagCrnt, 4).Value = "Key Expn"
'#      .Cells(RowDiagCrnt, 5).Value = "Value Expn"
'#      With .Cells(RowDiagCrnt, 6)
'#        .Value = "Total"
'#        .HorizontalAlignment = xlRight
'#      End With
'#      .Cells(RowDiagCrnt, 7).Value = "Diff"
'#      RowDiagCrnt = RowDiagCrnt + 1
'#      For RowPendCrnt = 1 To RowPendCrntMax
'#        .Cells(RowDiagCrnt, 2).Value = RowPendCrnt
'#        With .Cells(RowDiagCrnt, 3)
'#          .Value = Pending(RowPendCrnt, ColPendExpn)
'#          .Font.Name = "Courier New"
'#        End With
'#        Call GenExpn(Pending(RowPendCrnt, ColPendExpn), ExpnKeyCrnt, ExpnValueCrnt)
'#        .Cells(RowDiagCrnt, 4).Value = ExpnKeyCrnt
'#        .Cells(RowDiagCrnt, 5).Value = "'" & ExpnValueCrnt
'#        .Cells(RowDiagCrnt, 6).Value = "=" & ExpnValueCrnt
'#        With .Cells(RowDiagCrnt, 7)
'#          .Value = Format(Pending(RowPendCrnt, ColPendDiff), "#,##0")
'#        End With
'#        RowDiagCrnt = RowDiagCrnt + 1
'#      Next
'#
'#    End With
'#    RowDiagCrnt = RowDiagCrnt + 1

  Loop  ' While RowPendCrntMax > 0

  ' Will only fall out the bottom of the loop if Result array not full of on-target
  ' results.  Final version of Result array will not have been written to worksheet

'#  With Worksheets("Diag")
'#    .Columns("A:" & ColNumToCode(UBound(Result, 2) + 2)).AutoFit
'#  End With

  With Worksheets(WshtRsltName)
    .Range(.Cells(RowRsltWshtDataFirst, 1), _
           .Cells(RowRsltWshtDataFirst + UBound(Result, 1) - 1, _
                                         UBound(Result, 2))) = Result
    .Columns("A:" & ColNumToCode(UBound(Result, 2))).AutoFit
  End With
  ThisWorkbook.Save

  Application.DisplayStatusBar = False
  Debug.Print "Max Pending=" & RowPendMaxMax

  Debug.Print "Duration (sss.ss): " & Format(Timer - TimeStart, "#,##0.00")
  TimeStart = Timer - TimeStart
  Debug.Print "Duration (m:ss): " & Format(TimeStart \ 60, "#,##0") & ":" & Format(TimeStart Mod 60, "00")

End Sub

方法3代码-第2部分

---

它不是VBA解决方案，因此也不是特别有效，不过如果您感兴趣，也许您可以调整我在这里提供的设置以满足您的需要：谢谢XOR，它不是VBA，但无论如何看起来都很有用！你能再举几个例子吗。我只需要B列的最小值/最大值/平均值/计数和目标最小值和最大值。理想情况下，示例应具有高计数、高目标最小值和低目标范围绝对目标最小值/最大值差。谢谢Tony！我不理解每一步，但我尝试过，效果很好，奇怪的是，最多15个元素的速度非常快，但随后我会出现溢出。我将使用更多的键/值进行测试，然后返回给您。在16个元素中，使用了2^16个单元格，但旧版本的excel只允许使用2^16-1个单元格。数组长度也可能受此限制。@Luis我添加了一个新的部分，解释了溢出的原因。Nuclearman的解释只是部分正确。我解释了如何用15个值修复溢出。我还展示了宏的持续时间如何随着值的增加而增加。如果这种方法不符合您的要求，我有另一种方法的想法。我一定是找错了地方，因为我检查的源代码显示了32位整数类型，尽管这是我对这个问题的第三种猜测。这也可能是一个很好的公式，这样您就可以使用。通过设置s=Max和求解Min=1− c代表c。如果最小/最大范围足够大，足以证明它的使用。非常感谢Tony，现在我完全理解了它是如何工作的。问题是，我仍然得到2x元素的溢出。可能是通过vba的限制？这显然是你之前发布的优化版本，但元素的数量仍然有限。我不能肯定，但我强烈怀疑你的算法可能使用了类似的东西，不容易定义复杂度。然而，对于某些类型的问题，它是相当有效的。此外，您可能希望尝试在测试中使用上面提到的Luis值范围。路易斯：也许你应该发布你正在使用的Excel/VBA软件版本。托尼：你可能还想发布一个测试excel电子表格的屏幕截图，也许Luis做了一些稍微不同的事情。@Luis我已经用你的原始数据和最多26个键值测试了我的新例程。它不能是同一个溢出，因为以前提供它的代码已经消失。新的溢流阀在哪里？你能发布以溢出结束的数据吗？@Luis第二种方法不是第一种方法的优化版本。几乎没有什么解决方案可以提供一切

---

兴,；通常会有妥协。第一个版本针对实现速度和重用旧代码进行了优化。第二个版本速度更快，但使用了更复杂的方法，调试时间更长，代码不太可能重复使用。@Nuclearman您的参考并没有真正确定B&B方法的定义特征。你可能会说我在找一棵树，尽管我不是这么想的。我没有使用递归。我会考虑对回答的方法进行更多的解释，这样你就可以给出更多的考虑意见。当我发布这个问题的时候，我想象不出像你这样的答案。显然出乎意料。在这里，你给学生的不仅仅是一个答案。希望这里有一个更好的答案。非常感谢@Luis您需要通过单击轮廓箭头将其移动到顶部来接受答案。对于我最初的回答，我发布了一个很久以前编写的例程。随着您需求的规模变得越来越清晰，如果Nuclearman没有与我决定探索的方法联系起来，我怀疑我是否会费心。

Function ColNumToCode(ByVal ColNum As Long) As String

  Dim Code As String
  Dim PartNum As Long

  ' Last updated 3 Feb 12.  Adapted to handle three character codes.
  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    Code = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      Code = Chr(65 + PartNum) & Code
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = Code

End Function
Function OutputRslt(Pending, RowPendCrnt, Result, RowRsltArrNext) As Boolean

  ' * Output row Pending(RowPendCrnt) to array Result providing:
  '    *    Result is not full
  '    * or the new row's total is closer to the target than the existing row
  '         whose total is furthest from the target
  ' * The routine returns True unless Result is full of on-target rows.

  ' Static variables are private to this routine but their values are preserved
  ' from call to call.
  ' DiffAbsBest is only used for the status bar message
  ' DiffAbsWorst allows a quick check to see if a new result is to be saved
  Static DiffAbsBest As Long
  Static DiffAbsWorst As Long

  ' Not really important.  Allows the range for the results in the results
  ' worksheet to be calculated once rather than one per save.
  Static RngRsltWsht As Range

  ' The row holding the current worst result
  Static RowRsltArrDiffAbsWorst As Long

  ' It appears that if a workbook is saved too frequently, Excel can end with a
  ' workbook that cannot be saved either with VBA or with the keyboard.  Used to
  ' ensure workbook is not saved more than once per minute but is saved
  ' regularly if changes are made.
  Static RecentChange As Boolean
  Static TimeLastSave As Double

  ' Values for the result current being saved
  Dim DiffAbsCrnt As Long
  Dim ExpnKeyCrnt As String
  Dim ExpnValueCrnt As String

  ' Control variable for For-Loop
  Dim RowRsltArrCrnt As Long

  DiffAbsCrnt = Abs(Pending(RowPendCrnt, ColPendDiff))
  If RowRsltArrNext >= UBound(Result, 1) Then
    ' Result already full.
    If DiffAbsWorst = DiffAbsCrnt And DiffAbsCrnt = 0 Then
      Debug.Assert False
      ' Should not be possible to get here. Result being full of
      ' on-target totals should have been reported when last
      ' non-on-target row overwritten
      OutputRslt = False
      If RecentChange Then
        ' The array Results has been changed since it was last saved to the worksheet.
        RngRsltWsht.Value = Result
        Worksheets(WshtRsltName).Columns("A:" & ColNumToCode(UBound(Result, 2))).AutoFit
        RecentChange = False
        ThisWorkbook.Save  ' Might be better to remove this statement and let user save
        TimeLastSave = Timer
      End If
    ElseIf DiffAbsWorst > DiffAbsCrnt Then
      ' This result to be saved
    Else
      ' Do not keep this result
      OutputRslt = True     ' Result not full of on-target combinations
      If TimeLastSave > Timer Then
        Debug.Assert False
        ' Have gone over midnight.  Reset TimeLastSave
        TimeLastSave = Timer
      End If
      If TimeLastSave + 60# < Timer Then
        ' It has been at least one minute since the last save
        RngRsltWsht.Value = Result
        Worksheets(WshtRsltName).Columns("A:" & ColNumToCode(UBound(Result, 2))).AutoFit
        RecentChange = False
        ThisWorkbook.Save
        TimeLastSave = Timer
      End If
      Exit Function
    End If  ' DiffAbsWorst < DiffAbsCrnt | DiffAbsWorst = DiffAbsCrnt
  End If  ' RowRsltArrNext >= UBound(Result, 1) ' Result already full.

  ' This result will be kept either by adding it to a partially empty
  ' Result array or by overwriting an existing result whose total is
  ' further from the target than the new result total is.

  Call GenExpn(Pending(RowPendCrnt, ColPendExpn), ExpnKeyCrnt, ExpnValueCrnt)

  If RowRsltArrNext > UBound(Result, 1) Then
    ' Result already full but new combination is better than current worst
    ' "=" before ExpnValueCrnt to ensure treated as a formula by Excel
    Result(RowRsltArrDiffAbsWorst, ColRsltTotal) = "=" & ExpnValueCrnt
    Result(RowRsltArrDiffAbsWorst, ColRsltDiffAbs) = DiffAbsCrnt
    Result(RowRsltArrDiffAbsWorst, ColRsltExpnKey) = ExpnKeyCrnt
    ' "'" before ExpnValueCrnt to ensure not treated as a formula by Excel
    Result(RowRsltArrDiffAbsWorst, ColRsltExpnValue) = "'" & ExpnValueCrnt
    ' New result could be new best
    If DiffAbsBest > DiffAbsCrnt Then
      DiffAbsBest = DiffAbsCrnt
    End If
    ' There could be rows with a DiffAbs between the previous worst and the
    ' new row so search for new worst
    DiffAbsWorst = DiffAbsCrnt
    For RowRsltArrCrnt = 1 To UBound(Result, 1)
      If Result(RowRsltArrCrnt, ColRsltDiffAbs) > DiffAbsWorst Then
        RowRsltArrDiffAbsWorst = RowRsltArrCrnt
        DiffAbsWorst = Result(RowRsltArrCrnt, ColRsltDiffAbs)
      End If
    Next
  Else
    ' Result not full.  Add new result.
    If RowRsltArrNext = 1 Then
      ' First result being stored
      DiffAbsBest = DiffAbsCrnt
      DiffAbsWorst = DiffAbsCrnt
      RowRsltArrDiffAbsWorst = RowRsltArrNext
      With Worksheets(WshtRsltName)
        Set RngRsltWsht = _
                 .Range(.Cells(RowRsltWshtDataFirst, 1), _
                        .Cells(RowRsltWshtDataFirst + UBound(Result, 1) - 1, _
                                                     UBound(Result, 2)))
      End With
      RecentChange = True
      TimeLastSave = Timer - 61#      ' Force initial save
    Else
      ' Subsequent result being stored
      If DiffAbsBest > DiffAbsCrnt Then
        DiffAbsBest = DiffAbsCrnt
      End If
      If DiffAbsWorst < DiffAbsCrnt Then
        DiffAbsWorst = DiffAbsCrnt
        RowRsltArrDiffAbsWorst = RowRsltArrNext
      End If
    End If
    ' "=" before ExpnValueCrnt to ensure treated as a formula by Excel
    Result(RowRsltArrNext, ColRsltTotal) = "=" & ExpnValueCrnt
    Result(RowRsltArrNext, ColRsltDiffAbs) = DiffAbsCrnt
    Result(RowRsltArrNext, ColRsltExpnKey) = ExpnKeyCrnt
    ' "'" before ExpnValueCrnt to ensure not treated as a formula by Excel
    Result(RowRsltArrNext, ColRsltExpnValue) = "'" & ExpnValueCrnt
    RowRsltArrNext = RowRsltArrNext + 1
  End If
  RecentChange = True

  Application.StatusBar = "Current results; closest to furthest from target: " _
                          & Format(DiffAbsBest, "#,##0") & " to " _
                          & Format(DiffAbsWorst, "#,##0")

  If RecentChange Then
    ' The array Results has been changed since it was last saved to the worksheet.
    If TimeLastSave > Timer Then
      Debug.Assert False
      ' Have gone over midnight.  Reset TimeLastSave
      TimeLastSave = Timer
    ElseIf TimeLastSave + 60# < Timer Then
      ' It has been at least one minute since the last save
      RngRsltWsht.Value = Result
      Worksheets(WshtRsltName).Columns("A:" & ColNumToCode(UBound(Result, 2))).AutoFit
      RecentChange = False
      ThisWorkbook.Save
      TimeLastSave = Timer
    End If
  End If

  If DiffAbsWorst = 0 Then
    OutputRslt = False      ' Result is full of on-target rows
    If RecentChange Then
      ' The array Results has been changed since it was last saved to the worksheet.
      RngRsltWsht.Value = Result
      Worksheets(WshtRsltName).Columns("A:" & ColNumToCode(UBound(Result, 2))).AutoFit
      RecentChange = False
      ThisWorkbook.Save  ' Might be better to remove this statement and let user save
      TimeLastSave = Timer
    End If
  Else
    OutputRslt = True
  End If

End Function
Sub GenExpn(ByVal PendExpn As String, ByRef RsltExpnKey As String, _
                                      ByRef RsltExpnValue As String)

  ' This routine generates RsltExpnKey and RsltExpnValue from PendExpn.

  ' PendExpn      A string of +s and -s representing a combination; for
  '               example "+--+--+"  Each + or - represents a row in
  '               the KeyValue table.  This combination is rows 1, 4 and 7.
  '               See definition of Pending array for more information
  ' RsltExpnKey   A string of the form "A+D+G" where A, B and G represent the
  '               keys from the rows identified by PendExpn.
  ' RsltExpnValue A string of the form "A+D+G" where A, B and G represent the
  '               values from the rows identified by PendExpn.

  Dim PosPE As Long

  RsltExpnKey = ""
  RsltExpnValue = ""

  For PosPE = 1 To Len(PendExpn)
    If Mid(PendExpn, PosPE, 1) = "+" Then
      If RsltExpnKey <> "" Then
        RsltExpnKey = RsltExpnKey & "+"
      End If
      RsltExpnKey = RsltExpnKey & KeyValue(PosPE, ColKVKey)
      If KeyValue(PosPE, ColKVValue) < 0 Then
        RsltExpnValue = RsltExpnValue & KeyValue(PosPE, ColKVValue)
      Else
        RsltExpnValue = RsltExpnValue & "+" & KeyValue(PosPE, ColKVValue)
      End If
    End If
  Next

End Sub