问题
Ok, I´ve found similar questions but none of them solve this problem so here I go:
I´ve a list of individuals (col. "A"), and each of them has a value assigned for a determined parameter (col. "B"). I´ve some target parameter values and I want to know which combinations of individuals sum up "x" for that parameter value.
Let´s take an example:
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
As you can see just by inspection, the only ways to do this is taking Q, or Q+P. But in my case, I´ve between 10-15 subjects each time, and doing the work by inspection is not easy at all.
I would want to generate a chart with all the possible values (being able to know which subjects are generating the value), or just a way to know the "y" closest combinations.
回答1:
The original question involved 5 values for which a brute force approach was acceptable. The number of values was then increased and more sophisticated approaches were required. I suggest you start with this answer, which describes the brute force approach, followed by:
- Approach 2
- Approach 3
- Approach 3, code part 1
- Approach 3, code part 2
First answer
You need to break your requirement into a number of simple steps. It may be possible to combine two or more steps but complex steps take more time to write and more time to debug. Start simple. Once your code is working, you can worry about making faster or prettier or whatever is necessary. Too many programmers forget that fast, pretty code that does not work is useless.
I created a worksheet “Source” and populated it with values so:
I need to put the minimum and maximum values somewhere so I placed them on this worksheet.
I created a worksheet “Result”. The output from the macro below is:
You do not list “10 M” as a solution. I do not know if this is an oversight or if your interpretation of range “9-10” is different from mine. Change the line If ValueMin <= ValueCrnt And ValueMax >= ValueCrnt Then if necessary.
I notice that my columns are not in the same sequence as yours. This is an easy change which I leave for you as an exercise.
There are three major steps in my solution.
Step 1
On my worksheet the relevant data is on rows 2 to 6. You indicate you will want to add further values. The start row is fixed so I have defined it using a constant:
Const RowSrcDataFirst As Long = 2
The value of RowSrcDataLast, the last row containing data, is determined by code.
Step 2
Although your objective is to process keys and values, you are interested in rows at this stage. For example:
- Is the value on row 2 within the required range?
- Is the sum of the values on rows 2 and 3 within the required range?
- Is the sum of the values on rows 2, 4 and 6 within the required range?
If the answer to any of these questions is “Yes”, then create an expression from the keys.
You need the row numbers to get at the keys and values.
My macro fills the array SrcRows with the values 2 to RowSrcDataLast. It then calls a subroutine GenerateCombinations. I use variations of this subroutine for any problem of this type.
GenerateCombinations takes two arrays as parameters, Value and Result, plus a separator characters. On return, Result returns an array containing a concatenated string for every combination of the values in Value. If Value contains the values: 2, 3, 4, 5 and 6, the returned strings are:
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
I think there are enough comments within the routine to explain how it generates this result.
Step 3
The macro loops down the returned array, splitting the returned string and accessing each row of that combination.
I hope that all makes sense. Come back with questions if necessary but the more you can decipher my code by yourself, the faster you will understand it.
Code
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
New section
Nuclearman's explanation of the overflow is partially correct. Data type Integer always specifies a 16-bit signed integer. This is not dependent on the Excel version. Arrays sizes are not a limiting issue.
The macro GenerateCombinations was originally written years ago when data type Integer was appropriate. I failed to notice these definitions:
Dim InxRMax As Integer ' Maximum used entry in array Result
Dim InxVRCrnt As Integer ' Working index into arrays Value and InxResultCrnt
They should be replaced by:
Dim InxRMax As Long ' Maximum used entry in array Result
Dim InxVRCrnt As Long ' Working index into arrays Value and InxResultCrnt
Data type Long specifies a 32-bit signed integer which will fix the immediate problem.
Note: you should never use data type Integer on 32 or 64-bit computers because 16-bit integer require special (slow) processing.
The table below reveals the hidden problem:
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
The number of combinations of N values is 2^N. My macro is generating every possible combination and storing it as a string in an array. With 15 values that array has 32,768 entries which is one more than the maximum value for a 16-bit signed integer.
I corrected the data type of InxRMax to Long and timed the macro for different numbers of values. You can see that the duration approximately doubles for each extra value. I am not willing to test the maco with 21 or more values. The macro would have failed again if I had tried 31 values and waited until it had finished.
If this is a one-off exercise and you have than 20 values, this approach may still be appropriate because you can leave the macro running and do something else for 6, 12, 24 or 48 minutes. This approach will not be appropriate if you have more than a few values and you want to run the macro repeatedly fot different sets of values.
回答2:
Second answer
My first answer is, I believe, about as simple a solution as is possible:
- The steps are completely separate making then easier to code and understand.
- Most of the work is within a routine I have used before and will no doubt use again.
- Has an acceptable duration for small numbers of items.
- Is not affected by having both positive and negative values.
This answer uses a different approach. The steps are not separate, making them more complicated, and I doubt I have a future use for this code. The approach is affected by having negative numbers but I have coded around that issue. The big advantage is that the duration is substantially reduced.
I do not believe this is an implementation of the algorithm referenced by Nuclearman. Apparently that algorithm requires all numbers to be positive and involves a sort per element; neither of which is true for my approach.
The duration of my macro is dependent on the range of values and I lack the mathematical skill to determine an expected upper value for the duration. The table below gives indicative durations:
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
The duration of approach 1 doubles with each extra item because it tests every possible combination. Approach 2 is more complicated and is slower with smaller number of items but by only testing a small proportion of the possible combinations it is the quicker approach with larger number of items. I have used the same data for the Approach 1 and 2 tests so I believe this gives an indication of durations you might expect.
The first step in approach 2 is to sort the KeyValue table into ascending order by value.
The next step is to import the KeyValue table from the worksheet to an array. This could have been done with Approach 1 but that approach was all about simplicity while Approach 2 is about doing anything to reduce the duration.
Suppose a combination is a selection from Value(1) to Value(N). If adding Value(N+1) to the combination takes the total over the maximum then adding any later value would also take the total over the maximum because all later values are larger than Value(N+1). Therefore, any addition to this combination will take it over the maximum total and no extension need be considered.
I have been much more careful with the documentation within the Approach 2 macros. I believe I have full explained the approach and its implementation. However, come back with questions if necessary.
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
回答3:
Code for Approach 3 - Part 1
The formatted code is too big for a single answer. Load part 1 followied by part 2 to their own module.
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
回答4:
Code for Approach 3 - Part 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
回答5:
Third approach
Approach 1 tested every possible combination. This approach was easy and simple to code and would be adequate if there were not too many items in the set. You have increased the number of items in your set so much that this approach is not viable.
Approach 2 and 3 both identify blind alleys to reduce the number of combinations tested. Both approaches sort the set into ascending order but use different techniques for identifying blind alleys. Once I had thought of approach 3, I was confident that it would be better than approach 2. However, if there is a technique for proving approach 3 was the better approach without testing it, I am not clever enough to know it.
Changes to solution 3 that are not related to the approach
This section describes changes which are better ways of parameterising the macros and better ways of presenting the results and which would have been included in solution 1 and 2 if I had thought of them earlier.
I found having a range of targets, X ± A, where A is small awkward with smaller sets of keys. Make A too small and I would get no matches. Make A too large and I would get an over large number of matches.
I replaced a range with a single target and introduced a new parameter: the number of rows in the results table, RowRsltArrMax. This means that instead of having to guess a range that will give me an acceptable number of results, the routine gives me the best RowRsltArrMax results or stops when it has found RowRsltArrMax on-target results.
Having a fixed number of results makes it easier to manage them. Instead of writing each in-range result straight to the worksheet, I have an array ready to write to the worksheet. The first RowRsltArrMax results are written to the array regardless of how on or off-target they are. After that, any new result overwrites the previous worst result if it is better. Here “better” means has a total that is closer to the target.
The routine now displays a message in the status bar:
Current results; closest to furthest from target: N to M
When I first created the third solution, I wrote the result array to the worksheet and saved the workbook each time the result array was updated. I knew this would slow the macro but I thought having the best available results stored on disc in the event of a problem was worth the time. However, I encountered a problem. Sometimes the macro would stop on ThisWorkbook.Save. The previous version of the workbook was correctly saved on disc but the version in memory could not be saved by VBA or via the keyboard. I guessed this was something to do with how often the workbook was being saved and changed the routine so that the result array was written to the worksheet and the workbook saved once per minute if results better than those already saved are being found. This change appears to have eliminated the save problem and revealed that saving the workbook every time a new result was saved was dramatically slowing the macro as shown by these results:
---- 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
These timings were with a KeyValue table containing 43 rows, random values between −300,000 and 1,000,000 and a target of 653,441. The values for the final row of the above table were created by setting RowRsltArrMax so high that every combination summing to the target was found.
Solution 3
This image shows the top of the KeyValue table and the Target value.
This image shows the results worksheet after a run with RowRsltArrMax = 10. The formula bar shows cell A2 = cell D2 except the A2 value has = at the beginning so Excel treats it as a formula while D2 has ' at the beginning so Excel treats it as a string.
I have not found it easy to describe the technique behind solution 3. In outline, the technique is to:
- Seed a Pending table by creating one combination for each positive value. Seeds are not created for keys with negative values to avoid generating the same combination more than one,
- Loop repeating step 3 until either the Results table is full of on-target results or the Pending table is empty.
- Remove the bottom row from the Pending table. Consider adding it to the Results table as described in step 4. Attempt to generate more combinations from it as discussed in step 5.
- Every row removed from the Pending table is added to the Results table until it is full. Once the Results table is full, the total of each new combination is compared against the worst total so far. If the new total is better, the new row overwrites the worst row so far.
- If the total of the new combination is less than the target total, generate one new combination for each positive value that is larger than any existing positive values within the combination. If the total of the new combination is more than the target total, generate one new combination for each negative value that is larger than any existing negative values in the combinations. The “larger” restrictions avoid generating the same combination more than once.
Macro Control3 contains code that will output the contents of the Pending and Results tables to worksheet “Diag” before the first loop and at the end of every loop. This code is current commented out (see statements starting ‘#) because it should only be used with small KeyValue tables. If you removing the ‘#s and run the macro with a small set and a small Results table you will generate diagnostic information in worksheet “Diag” which you can work down to see what the macro does at every step.
The diagram below might help. For this diagram, I set RowRsltArrMax= 5 and created a 6 row KeyValue table. After sorting, the KeyValue table is loaded to an array for easy access:
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
The Pending array has two columns: Expn and Diff. Expn contains strings that represent a combination while Diff contains the difference between the total value of the combination and the Target. The Pending array is seeded with one row per positive value from the KeyValue table. The left column of the diagram below represents the seeds. The top row of each box contains a combination, the second row contains the total value of that combination and the third contains shows that total value as Target minus the total value.
The Pending array is only seeded with positive values; this is one of three restrictions that ensure the same combination cannot be generated more than once. This particular restriction means that no combination containing only negative values can be generated. This will only be issue if the target value is negative or a low positive value. This technique could be extended to allow for such target values but I assume this is not necessary.
The routine loops until the Pending array is empty. Each repeat removes the bottom row of the Pending table as a possibly satisfactory combination and then adds rows to the Pending table for any possibly better combination it can generate from the one just removed.
Consider the bottom left box in the diagram. Key AD has a value of 852,254 which is 198,813 more than the target. We can hope this is not the best combination to be found but it will be placed in the Results array until something better is found.
Since this combination has a total above the target, only adding negative values could lead to a better combination. Since the combination does not contain any negative values, one combination is created and added to the Pending array for each negative value. These new combinations are shown in the bottom right of the diagram.
Both of these new combinations will in turn be taken as the second and third entry in the Result array. However, never of these combinations can be the basis for a better combination.
AB+AD has a total 6,269 below the target so we would have to add positive values get a better combination. However, this combination already contains AD which is the lowest positive value in the KeyValue table. The second restriction to ensure only one copy of each combination is that only positive values below any existing positive values can be added. The combination AB+AA+AD will be created later by adding AD to AB+AA.
AF+AD has a total 124,505 above the target so we would have to add negative values get a better combination. However, this combination already contains AF which is the lowest negative value in the KeyValue table. The third restriction to ensure only one copy of each combination is that only negative values below any existing negative values can be added.
The next combination to be taken as a possible result is AA. The diagram shows that AF+AA and AB+AA will be generated from it. No further combination can be generated from AF+AA but AB+AA+AD can be generated from AB+AA. No further combination can be generated from AB+AA+AD.
If you want to explore the combinations generated from AE and AC, create a KeyValue table to match mine and run the macro with the diagnostic code active.
I cannot devise a technique that will examine fewer combinations than this one. I have more-or-less convinced myself that potentially good combinations are not ignored. Since it finds so many on-target combinations with larger sets, it may not matter if a few are overlooked.
The secret of any such technique is to correctly identify blind alleys at the earliest possible moment. I have identified two. Perhaps you can identify one that is better than either of mine. Good luck.
I have have had to post the code for Approach 3 separately because of the character limit on the size of an answer.
来源：https://stackoverflow.com/questions/26539996/combinatorics-in-excel-find-every-possible-sum-of-every-possible-combination