excel中的组合：找出每种可能组合的所有可能总和
好的，我发现了类似的问题，但没有一个能解决这个问题所以我去了：
我有个人名单（col。“A”），每个人都有一个确定参数的值（col。“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”最接近组合的方法。
4 个答案:
答案 0 :(得分：2)
原始问题涉及可接受蛮力方法的5个值。然后增加值的数量并且需要更复杂的方法。我建议你从这个答案开始，它描述了蛮力方法，然后是：
第一个回答
您需要将您的要求分解为许多简单的步骤。可以组合两个或更多个步骤，但复杂的步骤需要更多的时间来编写和更多的时间来调试。从简单开始。一旦你的代码工作，你可以担心更快或更漂亮或任何必要的。太多的程序员忘记了快速，漂亮的代码无效。
我创建了一个工作表“Source”并用值填充它：
我需要将最小值和最大值放在某处，以便将它们放在此工作表上。
我创建了一个工作表“Result”。以下宏的输出是：
您没有列出“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到SrcRows填充数组RowSrcDataLast。然后它调用子例程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
我认为例程中有足够的注释来解释它是如何产生这种结果的。
第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位有符号整数的最大值多一个。
我将InxRMax的数据类型更正为Long，并为不同数量的值计时宏。您可以看到每个额外值的持续时间大约翻倍。我不愿意用21或更多值来测试maco。如果我尝试了31个值并等到它完成后，宏将再次失败。
如果这是一次性练习并且您有超过20个值，则此方法可能仍然适用，因为您可以让宏保持运行并执行其他操作6,12,24或48分钟。如果您有多个值并且想要重复运行不同的值集，则此方法将不合适。
答案 1 :(得分：1)
第二个回答
我认为，我的第一个答案是尽可能简单的解决方案：
- 这些步骤是完全独立的，因此更易于编码和理解。
- 大部分工作都在我以前使用过的例程中，无疑会再次使用。
- 少量商品的持续时间可以接受。
- 不受正负值影响。
这个答案采用了不同的方法。这些步骤并不是分开的，使它们更加复杂，我怀疑我将来会使用这个代码。这种方法受到负数的影响，但我已经围绕这个问题进行了编码。最大的好处是持续时间大大减少。
我不相信这是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是关于做任何事情以减少持续时间。
假设组合是从值（1）到值（N）的选择。如果向组合中添加值（N + 1）使总数超过最大值，则添加任何后续值也会使总数超过最大值，因为所有后面的值都大于值（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
答案 2 :(得分：1)
方法3的代码 - 第1部分
格式化的代码对于单个答案来说太大了。将第2部分的第1部分加载到它们自己的模块中。
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 :(得分：1)
方法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
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？