Find a set of amounts
that match a target value
There are instances when one wants to figure
out which elements of a set of numbers (amounts) total to a target
value. This might occur for a company that receives a check
for outstanding accounts receivable (A/R) bills but doesn't have
matching documentation indicating what bills are being paid.
Excel template using
Solver
VBA code to
find multiple matching combinations
References
Excel template
using Solver
The Excel template uses Solver to provide one
possible combination of numbers that total to the target amount.
Note that like most numerical optimizations, it provides one
possible solution. Others may exist and might be found with a
different starting point. In addition, the template has
undergone only basic testing and may or may not be suitable for your
specific problem. Finally, both Solver and the underlying
methodology that it employees have inherent limitations in their
capabilities. Some of the limitations, especially in terms of
the size of the problem that can be solved, are imposed by Frontline
Systems, the producer of the Solver add-in. It's how it hopes
to sell commercial versions of the program, thereby subsidizing the
free version that is included with Microsoft Excel.
The Excel
template
VBA code
to find multiple matching combinations
There have been several requests for
solutions that provide a list of all possible matches.
From the perspective of practicality, one should keep in mind
that listing a handful of combinations may allow one to pick the
most appropriate or the most meaningful (in the context of one's
work). However, the human mind is unlikely to work well
when presented with a lot of valid combinations. Also, the
code below may take a fair amount of time to run depending on
the size of the list of numbers being searched.
As far as I can tell the code below is
easy to understand and is also probably about as fast as one can
get. Put the code below in a standard module.
The data for the search
should be organized in a single contiguous range in one column.
| The first cell
contains the maximum number of solutions to
be found. If the cell contains zero
all solutions will be found. |
| The second cell
contains the target value.
|
| The values that are to be matched follow. |
Select the range containing all the
information (the cell indicating the maximum number of
solutions, the target value, and all the values to be matched),
and use ALT+F8 to run the startSearch procedure.
Option Explicit
Function RealEqual(A, B, Epsilon As Double)
RealEqual = Abs(A - B) <= Epsilon
End Function
Function ExtendRslt(CurrRslt, NewVal, Separator)
If CurrRslt = "" Then ExtendRslt = NewVal _
Else ExtendRslt = CurrRslt & Separator & NewVal
End Function
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _
ByVal CurrIdx As Integer, _
ByVal CurrTotal, ByVal Epsilon As Double, _
ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
Dim I As Integer
For I = CurrIdx To UBound(InArr)
If RealEqual(CurrTotal + InArr(I), TargetVal, Epsilon) Then
Rslt(UBound(Rslt)) = (CurrTotal + InArr(I)) _
& Separator & Format(Now(), "hh:mm:ss") _
& Separator & ExtendRslt(CurrRslt, I, Separator)
If MaxSoln = 0 Then
If UBound(Rslt) Mod 100 = 0 Then Debug.Print UBound(Rslt) & "=" & Rslt(UBound(Rslt))
Else
If UBound(Rslt) >= MaxSoln Then Exit Sub
End If
ReDim Preserve Rslt(UBound(Rslt) + 1)
ElseIf CurrTotal + InArr(I) > TargetVal + Epsilon Then
ElseIf CurrIdx < UBound(InArr) Then
recursiveMatch MaxSoln, TargetVal, InArr(), I + 1, _
CurrTotal + InArr(I), Epsilon, Rslt(), _
ExtendRslt(CurrRslt, I, Separator), _
Separator
If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
Else
'we've run out of possible elements and we _
still don't have a match
End If
Next I
End Sub
Function ArrLen(Arr()) As Integer
On Error Resume Next
ArrLen = UBound(Arr) - LBound(Arr) + 1
End Function
Sub startSearch()
'The selection should be a single contiguous range in a single column. _
The first cell indicates the number of solutions wanted. Specify zero for all. _
The 2nd cell is the target value. _
The rest of the cells are the values available for matching. _
The output is in the column adjacent to the one containing the input data.
Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer
StartTime = Now()
MaxSoln = Selection.Cells(1).Value
TargetVal = Selection.Cells(2).Value
InArr = Application.WorksheetFunction.Transpose( _
Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
ReDim Rslt(0)
recursiveMatch MaxSoln, TargetVal, InArr, LBound(InArr), 0, 0.00000001, _
Rslt, "", ", "
Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
ReDim Preserve Rslt(UBound(Rslt) + 1)
Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _
Application.WorksheetFunction.Transpose(Rslt)
End Sub
|
|
