excel中的组合：找到每个可能组合的每个可能的总和

Question

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

我有一个个人列表（列“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”最接近组合的方法。

Answer 1

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

• Approach 2
• Approach 3
• Approach 3, code part 1
• Approach 3, code part 2

第一个答案

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

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

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

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

您没有将“10 M”列为解决方案。我不知道这是否是疏忽，或者您对“9-10”范围的解释是否与我的不同。如有必要，更改行 If ValueMin <= ValueCrnt And ValueMax >= ValueCrnt Then。

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

我的解决方案分为三个主要步骤。

第 1 步

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

Const RowSrcDataFirst As Long = 2 

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

第 2 步

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

• 第 2 行的值是否在要求的范围内？
• 第 2 行和第 3 行的值之和是否在要求的范围内？
• 第 2、4 和 6 行的值的总和是否在要求的范围内？

如果其中任何一个问题的答案是“是”，则根据键创建一个表达式。

您需要行号来获取键和值。

我的宏用值 2 到 RowSrcDataLast 填充数组 SrcRows。然后它调用子程序GenerateCombinations。对于这种类型的任何问题，我都会使用这个子程序的变体。

GenerateCombinations 将两个数组作为参数，Value 和 Result，外加一个分隔符。返回时，Result 返回一个数组，该数组包含一个连接字符串，用于 Value 中的每个值组合。如果 Value 包含值：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

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

第 3 步

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

我希望一切都有意义。如有必要，请回来提出问题，但您自己破译我的代码的次数越多，您理解它的速度就越快。

代码

Option Explicit
Sub Control()

  ' Using constants instead of literals has the following effects:
  '  1) It takes longer to type the code.  For example:
  '       ValueMin = .Range(CellSrcMin).Value    takes longer to type than
  '       ValueMin = .Range("C3").Value
  '  2) The code is self-documenting.  The purpose of ".Range(CellSrcMin).Value"
  '     is a lot more obvious than the purpose of ".Range("C3").Value".  This may
  '     not matter today but, when you return to this macro in 6 months, self-
  '     documenting code is a real help.
  '  3) If a cell address, a column code or a worksheet name changes, all you
  '     have to do is change the value of the constant and the code is fixed.
  '     Scanning you code for every occurance of a literal and deciding if it
  '     one that needs to change is a nightmare.

  Const CellSrcMin As String = "C3"
  Const CellSrcMax As String = "D3"
  Const ColRsltValue As String = "A"
  Const ColRsltKeyExpn As String = "B"
  Const ColSrcKey As String = "A"
  Const ColSrcValue As String = "B"
  Const RowSrcDataFirst As Long = 2
  Const WshtNameRslt As String = "Result"
  Const WshtNameSrc As String = "Source"

  Dim InxResultCrnt As Long
  Dim InxResultPartCrnt As Long
  Dim InxSrcRowCrnt As Long
  Dim RowRsltCrnt As Long
  Dim RowSrcCrnt As Long
  Dim RowSrcDataLast As Long
  Dim SrcRows() As String
  Dim Result() As String
  Dim ResultPart() As String
  Dim ValueCrnt As Double
  Dim ValueKey As String
  Dim ValueMin As Double
  Dim ValueMax As Double

  ' Find last row containing data
  With Worksheets(WshtNameSrc)
    RowSrcDataLast = .Cells(Rows.Count, ColSrcKey).End(xlUp).Row
  End With

  ' Rows RowSrcDataFirst to RowSrcDataLast contain data.
  ' Size SrcRows so it can hold each value in this range
  ReDim SrcRows(1 To RowSrcDataLast - RowSrcDataFirst + 1)

  ' Fill SrcRows with every row that contains data
  RowSrcCrnt = RowSrcDataFirst
  For InxSrcRowCrnt = 1 To UBound(SrcRows)
    SrcRows(InxSrcRowCrnt) = RowSrcCrnt
    RowSrcCrnt = RowSrcCrnt + 1
  Next

  ' Generate every possible combination
  Call GenerateCombinations(SrcRows, Result, "|")

  ' Output contents of Result to Immediate Window.
  ' Delete or comment out once you fully understand what
  ' GenerateCombinations is doing.
  Debug.Print "Inx Combination"
  For InxResultCrnt = 0 To UBound(Result)
    Debug.Print Right("  " & InxResultCrnt, 3) & "  " & Result(InxResultCrnt)
  Next

  ' Get the minimum and maximum values
  With Worksheets(WshtNameSrc)
    ValueMin = .Range(CellSrcMin).Value
    ValueMax = .Range(CellSrcMax).Value
  End With

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

  With Worksheets(WshtNameSrc)

    ' Get the minimum and maximum values
    ValueMin = .Range(CellSrcMin).Value
    ValueMax = .Range(CellSrcMax).Value

    ' For each result except first which is no row selected
    For InxResultCrnt = 1 To UBound(Result)
      ResultPart = Split(Result(InxResultCrnt), "|")
      ValueCrnt = 0#
      For InxResultPartCrnt = 0 To UBound(ResultPart)
        ValueCrnt = ValueCrnt + .Cells(ResultPart(InxResultPartCrnt), ColSrcValue).Value
      Next
      If ValueMin <= ValueCrnt And ValueMax >= ValueCrnt Then
        ' This value within acceptable range
        Worksheets(WshtNameRslt).Cells(RowRsltCrnt, ColRsltValue) = ValueCrnt
        ' Create key string
        ValueKey = .Cells(ResultPart(0), ColSrcKey).Value
        For InxResultPartCrnt = 1 To UBound(ResultPart)
          ValueKey = ValueKey & "+" & .Cells(ResultPart(InxResultPartCrnt), ColSrcKey).Value
        Next
        Worksheets(WshtNameRslt).Cells(RowRsltCrnt, ColRsltKeyExpn) = ValueKey
        RowRsltCrnt = RowRsltCrnt + 1
      End If
    Next

  End With

End Sub
Sub GenerateCombinations(ByRef Value() As String, ByRef Result() As String, _
                         ByVal Sep As String)

  ' * On entry, array Value contains values.  For example: A, B, C.
  ' * On exit, array Result contains one entry for every possible combination
  '   of values from Value.  For example, if Sep = "|":
  '     0)             ' None of the values is an allowable combination
  '     1)  A
  '     2)  B
  '     3)  A|B
  '     4)  C
  '     5)  A|C
  '     6)  B|C
  '     7)  A|B|C
  ' * The bounds of Value can be any valid range,
  ' * The lower bound of Result will be zero.  The upper bound of Result
  '   will be as required to hold all combinations.

  Dim InxRMax As Integer        ' Maximum used entry in array Result
  Dim InxVRCrnt As Integer      ' Working index into arrays Value and InxResultCrnt
  Dim NumValues As Long         ' Number of values
  Dim InxResultCrnt() As Long   ' Entry = 1 if corresponding value
                                ' selected for this combination

  NumValues = UBound(Value) - LBound(Value) + 1

  ReDim Result(0 To 2 ^ NumValues - 1)                 ' One entry per combination
  ReDim InxResultCrnt(LBound(Value) To UBound(Value))  ' One entry per value

  ' Initialise InxResultCrnt for no values selected
  For InxVRCrnt = LBound(Value) To UBound(Value)
    InxResultCrnt(InxVRCrnt) = 0
  Next

  InxRMax = -1
  Do While True
    ' Output current result
    InxRMax = InxRMax + 1
    If InxRMax > UBound(Result) Then
      ' There are no more combinations to output
      Exit Sub
    End If
    Result(InxRMax) = ""
    For InxVRCrnt = LBound(Value) To UBound(Value)
      If InxResultCrnt(InxVRCrnt) = 1 Then
        ' This value selected
        If Result(InxRMax) <> "" Then
          Result(InxRMax) = Result(InxRMax) & Sep
        End If
        Result(InxRMax) = Result(InxRMax) & Value(InxVRCrnt)
      End If
    Next
    ' Treat InxResultCrnt as a little endian binary number
    ' and step its value by 1.  Ignore overflow.
    ' Values will be:
    '   000000000
    '   100000000
    '   010000000
    '   110000000
    '   001000000
    '   etc
    For InxVRCrnt = LBound(Value) To UBound(Value)
      If InxResultCrnt(InxVRCrnt) = 0 Then
        InxResultCrnt(InxVRCrnt) = 1
        Exit For
      Else
        InxResultCrnt(InxVRCrnt) = 0
      End If
    Next
  Loop

End Sub

新版块

Nuclearman 对溢出的解释部分正确。数据类型 Integer 始终指定一个 16 位有符号整数。这不依赖于 Excel 版本。数组大小不是限制性问题。

宏 GenerateCombinations 最初是在几年前编写的，当时数据类型为 Integer 是合适的。我没有注意到这些定义：

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

它们应该被替换为：

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 位整数需要特殊（慢）处理。

下表揭示了隐藏的问题：

                                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 个值，该数组有 32,768 个条目，比 16 位有符号整数的最大值多 1。

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

如果这是一次性练习并且您有超过 20 个值，则此方法可能仍然适用，因为您可以让宏运行并执行其他操作 6、12、24 或 48 分钟。如果您有多个值并且想要针对不同的值集重复运行宏，则此方法不合适。

Answer 2

第二个答案

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

1. 这些步骤是完全独立的，因此更易于编码和理解。
2. 大部分工作都在我以前使用过的例程中，毫无疑问会再次使用。
3. 对于少量项目具有可接受的持续时间。
4. 不受正负值的影响。

这个答案使用了不同的方法。这些步骤不是分开的，使它们更加复杂，我怀疑我将来会使用此代码。该方法受到负数的影响，但我已经围绕这个问题进行了编码。最大的优势是持续时间大大缩短。

我不相信这是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 是为了减少持续时间。

假设一个组合是从 Value(1) 到 Value(N) 的选择。如果将 Value(N+1) 添加到组合中使总和超过最大值，那么添加任何后面的值也会使总和超过最大值，因为所有后面的值都大于 Value(N+1)。因此，对该组合的任何添加都将超过最大总数，无需考虑扩展。

我对方法 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

Answer 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

Answer 4

方法 3 的代码 - 第 2 部分

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

Answer 5

第三种方法

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

方法 2 和 3 都可以识别死胡同，以减少测试组合的数量。两种方法都按升序对集合进行排序，但使用不同的技术来识别死胡同。一旦我想到了方法 3，我就确信它会比方法 2 更好。但是，如果有一种技术可以证明方法 3 是更好的方法而无需对其进行测试，我还不够聪明，无法知道它。

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

本部分描述了参数化宏的更好方法和呈现结果的更好方法的更改，如果我早先想到它们，这些更改将包含在解决方案 1 和 2 中。

我发现有一系列目标，X ± A，其中 A 对于较小的键集来说有点尴尬。使 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 表，随机值介于 -300,000 和 1,000,000 之间，目标为 653,441。上表最后一行的值是通过将RowRsltArrMax 设置得如此之高以找到每个总和到目标的组合来创建的。

解决方案 3

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

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

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

1. 通过为每个正值创建一个组合来播种待处理表。不会为具有负值的键创建种子，以避免生成多个相同的组合，
2. 循环重复第 3 步，直到 Results 表中满是目标结果或 Pending 表为空。
3. 从 Pending 表中删除底行。考虑将其添加到第 4 步中所述的结果表中。尝试从中生成更多组合，如第 5 步中所述。
4. 从 Pending 表中删除的每一行都会添加到 Results 表中，直到填满。一旦结果表填满，就会将每个新组合的总数与迄今为止最差的总数进行比较。如果新的总数更好，则新行将覆盖迄今为止最差的行。
5. 如果新组合的总和小于目标总和，则为每个大于组合中任何现有正值的正值生成一个新组合。如果新组合的总和大于目标总和，则为每个大于组合中任何现有负值的负值生成一个新组合。 “更大”的限制避免了多次生成相同的组合。

宏 Control3 包含的代码将在第一个循环之前和每个循环结束时将 Pending 和 Results 表的内容输出到工作表“Diag”。此代码当前已被注释掉（请参阅以“#”开头的语句），因为它只能用于小型 KeyValue 表。如果您删除“#s”并使用一个小集合和一个小的结果表运行宏，您将在工作表“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

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

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

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

考虑图中左下角的方框。关键 AD 的值为 852,254，比目标值多 198,813。我们可以希望这不是找到的最佳组合，但它将被放置在 Results 数组中，直到找到更好的组合。

由于此组合的总和高于目标，因此仅添加负值可能会导致更好的组合。由于该组合不包含任何负值，因此将为每个负值创建一个组合并将其添加到 Pending 数组中。这些新组合显示在图表的右下方。

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

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

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

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

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

我无法设计出一种技术来检查比这个更少的组合。我或多或少地说服自己，潜在的良好组合不会被忽视。由于它发现了许多具有较大集合的目标组合，因此忽略一些可能无关紧要。

任何此类技术的秘诀在于尽早正确识别死胡同。我已经确定了两个。也许你可以找出一个比我的任何一个都好。祝你好运。

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