Factorial total number finding loop

[Roderick_E]

I'm working to make a macro for my accounting team to look at a range of invoices that equal some user defined total. I've seen other solutions even using add-in Solver and none work as well as my version below. (No ego intended)
PROBLEM:
The problem is, my version below only goes out 4 levels (4 combinations of numbers to equal total). I'd like to use Excel's =FACT function to determine the factorial of the intended range of invoices so that the 4 levels is replaced with a dynamic level. (Yes I know a simple range of 12 numbers is 479001600)
As it stands now in the code, I could keep inserting more loops to get more levels of return but I simply want to do it dynamically and STILL get the exact match accuracy I've built into the code below. Can someone please figure out how to make my code dynamic? Thanks


current code:

Sub testgetcombo()
alerter = MsgBox("This assumes data in column A with no other data in any other columns, otherwise will clear other columns." & vbCr & "Continue?", vbYesNo, "**COMBINES TO 4 LEVELS ONLY**")
If alerter = vbYes Then
Range("B:IV").Clear
xSum = Application.InputBox("Input total to solve", "Get Total")
If InStr(xSum, "=") Then
xSum = Replace(Range(xSum), "=", "")
End If
xSum = Val(xSum)
lastrow = Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row
For x = 1 To lastrow
If Cells(x, 1) <= xSum Then
'exact match
If Cells(x, 1) = xSum Then
Cells(x, 2) = "Exact"
End If
'match 2
For y = 1 To lastrow
On Error Resume Next
If Cells(x, 2) <> "Exact" Then
If (Cells(x, 1) + Cells(y, 1)) <= xSum Then
If (Cells(x, 1) + Cells(y, 1)) = xSum Then
Cells(x, 3) = (Cells(x, 1) + Cells(y, 1))
If Cells(x, 3) <> "" Then
If Cells(x, 4) = "" Then
If Cells(x, 1).Address <> Cells(y, 1).Address Then
Cells(x, 4) = Cells(x, 1).Address & "+" & Cells(y, 1).Address
End If
End If
End If
End If
End If
End If
'macth 3
For Z = 1 To lastrow
On Error Resume Next
If Cells(x, 2) <> "Exact" Then
If (Cells(x, 1) + Cells(y, 1) + Cells(Z, 1)) <= xSum Then
If (Cells(x, 1) + Cells(y, 1) + Cells(Z, 1)) = xSum Then
Cells(x, 5) = (Cells(x, 1) + Cells(y, 1) + Cells(Z, 1))
If Cells(x, 5) <> "" Then
If Cells(x, 6) = "" Then
If Cells(x, 1).Address <> Cells(y, 1).Address And Cells(x, 1).Address <> Cells(Z, 1).Address And Cells(y, 1).Address <> Cells(Z, 1).Address Then
Cells(x, 6) = Cells(x, 1).Address & "+" & Cells(y, 1).Address & "+" & Cells(Z, 1).Address
End If
End If
End If
End If
End If
End If




'macth 4
For a = 1 To lastrow
On Error Resume Next
If Cells(x, 2) <> "Exact" Then
If (Cells(x, 1) + Cells(y, 1) + Cells(Z, 1) + Cells(a, 1)) <= xSum Then
If (Cells(x, 1) + Cells(y, 1) + Cells(Z, 1) + Cells(a, 1)) = xSum Then
Cells(x, 7) = (Cells(x, 1) + Cells(y, 1) + Cells(Z, 1) + Cells(a, 1))
If Cells(x, 7) <> "" Then
If Cells(x, 8) = "" Then
If Cells(x, 1).Address <> Cells(y, 1).Address And Cells(x, 1).Address <> Cells(Z, 1).Address And Cells(y, 1).Address <> Cells(Z, 1).Address And Cells(x, 1).Address <> Cells(a, 1).Address And Cells(y, 1).Address <> Cells(a, 1).Address And Cells(Z, 1).Address <> Cells(a, 1).Address Then
Cells(x, 8) = Cells(x, 1).Address & "+" & Cells(y, 1).Address & "+" & Cells(Z, 1).Address & "+" & Cells(a, 1).Address
Else
Cells(x, 7) = "" 'clear
End If
End If
End If
End If
End If
End If
Next a




Next Z


Resume Next
Next y


End If
Next x
End If
End Sub

 

[joeu2004]

Errata....

dt = Timer - st

In case we execute around midnight, that should be:

dt = Timer - st: If dt < 0 Then dt = dt + 86400

That assumes that the macro run-time is less than 24 hours; that is, we cross midnight only once, at most.

' we might sort d() and determine the first k values
' whose sum exceeds (or equals) target. TBD
' continuing...

That's a vestigial incomplete thought. It would allow us to skip the first 2^(k-1) combinations. But I decided it isn't worth the trouble. KISS!

The comment should be replaced with:

' find first combination of values whose sum is closest
' to target sum (might exceed target sum)

 

[fhqwgads]

i like using this code to find sums

Option Explicit

Function RealEqual(a, B, Optional Epsilon As Double = 0.00000001)
    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 HaveRandomNegatives As Boolean, _
        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 "Rslt(" & UBound(Rslt) & ")=" & Rslt(UBound(Rslt))
            Else
                If UBound(Rslt) >= MaxSoln Then Exit Sub
                End If
            ReDim Preserve Rslt(UBound(Rslt) + 1)
        ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(i) > TargetVal + Epsilon) Then
        ElseIf CurrIdx < UBound(InArr) Then
            recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _
                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
Function checkRandomNegatives(Arr) As Boolean
    Dim i As Long
    i = LBound(Arr)
    Do While Arr(i) < 0 And i < UBound(Arr): i = i + 1: Loop
    If i = UBound(Arr) Then Exit Function
    Do While Arr(i) >= 0 And i < UBound(Arr): i = i + 1: Loop
    checkRandomNegatives = Arr(i) < 0
    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.
    
    If Not TypeOf Selection Is Range Then GoTo ErrXIT
    If Selection.Areas.Count > 1 Or Selection.Columns.Count > 1 Then GoTo ErrXIT
    If Selection.Rows.Count < 3 Then GoTo ErrXIT
    
    Dim TargetVal, Rslt(), InArr(), starttime As Date, MaxSoln As Integer, _
        HaveRandomNegatives As Boolean
    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)
    HaveRandomNegatives = checkRandomNegatives(InArr)
    If Not HaveRandomNegatives Then
    ElseIf MsgBox("At least 1 negative number is present between positive numbers" _
                & vbNewLine _
            & "It may take a lot longer to search for matches." & vbNewLine _
            & "OK to continue else Cancel", vbOKCancel) = vbCancel Then
        Exit Sub
        End If
    ReDim Rslt(0)
    recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _
        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)
    Exit Sub
ErrXIT:
    MsgBox "Please select cells in a single column before using this macro" & vbNewLine _
        & "The selection should be a single contiguous range in a single column." & vbNewLine _
        & "The first cell indicates the number of solutions wanted.  Specify zero for all." & vbNewLine _
        & "The 2nd cell is the target value." & vbNewLine _
        & "The rest of the cells are the values available for matching." & vbNewLine _
        & "The output is in the column adjacent to the one containing the input data."
    End Sub

below is an example of it in action
say i wanted to find what numbers in D6:D13 added to 40. above the range that contains the numbers you want to sum, insert two more numbers, the first of which is the max number of combinations to find and the second being the sum you want to find which is 40 in this case. select all those numbers and run the code and it puts out the results in the next column over, where results have the sum you were looking for, the timestamp it was found and a list of numbers that correspond to the order your numbers appear in (i like to have helper column with the order of the numbers to help see what it's referring to). and the bottom if your list of results it has the end and start time that the code was running

Book1
	B	C	D	E
3		column for order of numbers for visualisation		column of results of vba
4	max number of combinations to find, 0 for allcombinations		0	40, 15:35:08, 1, 2, 6, 8
5	total to find		40	40, 15:35:08, 1, 3, 4, 6, 8
6		1	10	40, 15:35:08, 1, 3, 6, 7
7		2	20	40, 15:35:08, 1, 5
8		3	15	40, 15:35:08, 2, 3, 4
9		4	5	40, 15:35:08, 2, 4, 6, 7
10		5	30	40, 15:35:08, 5, 6, 8
11		6	7	15:35:08
12		7	8	15:35:08
13		8	3
Sheet5

 

[Roderick_E]

"Looking at all possible combinations". Shg is just explaining how to calculate that number (including zero).

There is no term for it, AFAIK. But it might offer insight into an efficient method for generating all combinations.



Fortunately, 2^n is a lot smaller than FACT. But it can still be prohibitive to iterate over all combinations. For "large" n, performance of the design becomes an important factor.

You should copy the range into a VBA array, instead of repeatedly using Cells or Range to access the Excel spreadsheet.

And for comparison purposes, you should explicitly round sums in order to avoid binary arithmetic anomalies that cause differences of an infinitesimal amount because most decimal fractions cannot be represented exactly.

Even better: copy the range into a VBA array of type Currency. That obviates the need to explicitly round repeatedly.

If you are selecting from 31 or fewer values to find the best sum (I, for one, cannot tolerate the time to iterate over more than 26 values, which requires as many as 67 million combinations), we can use ``For x=0 To 2^n-1`` to generate all combinations, using the binary pattern of x to select the values.

(Caveat: On my computer, iterating over 26 values takes more than 48 sec. Based on that, I estimate that iterating over 31 values would take more than 25 min.)

The following macro demonstrates one such implementation. Column A has 2 to 31 values, starting in A1. C1 has the target sum. When done, column B will have 1s and 0s to indicate the selected values, followed by the best sum and the target sum.

If you want to allow for a larger number of values, I would opt for a "limited" number of iterations of random selections (e.g. 1 million). With some care (and extra CPU time), we could avoid duplicate random selections. We can no longer use the binary pattern of a type Long variable for the selection; but we can accomplish the iteration paradigm with an array of 1s and 0s in place of the variable "x".

Notes: In this implementation, the best sum might be greater than the target sum. If you want the closest, but not greater sum, add ``s < targetSum And`` to the test for best sum.

Option Explicit

Sub doit()
Dim r As Range, v As Variant
Dim n As Long, i As Long, x As Long, b As Long, cnt As Long
Dim targetSum As Currency, s As Currency
Dim diff As Currency, bestDiff As Currency, bestSum As Currency
Dim bestX As Long
Dim st As Single, dt As Single

' copy values into VBA array (for efficiency)
' of type Currency (to avoid binary arithmetic anomalies)
st = Timer
targetSum = Range("c1")
Set r = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
v = r
n = UBound(v, 1)
If n > 31 Then
    MsgBox n & " values > 31: too many"
    Exit Sub
End If
ReDim d(1 To n) As Currency
For i = 1 To n: d(i) = v(i, 1): Next

' we might sort d() and determine the first k values
' whose sum exceeds (or equals) target. TBD
' continuing...
bestDiff = 922337203685477.58@    ' max Currency
For x = 1 To 2 ^ n - 1
    cnt = cnt + 1
    If cnt Mod 1000000 = 0 Then DoEvents    ' allow for breaking VBA execution
    ' select values and accumulate sum
    b = 1
    s = IIf(x And 1, d(1), 0)
    For i = 2 To n
        b = b * 2
        If x And b Then s = s + d(i)
    Next
    ' test for best sum
    diff = Abs(s - targetSum)
    If diff < bestDiff Then
        bestDiff = diff: bestSum = s: bestX = x
        If s = targetSum Then Exit For
    End If
Next x

' identify values selected for best sum
ReDim sel(1 To n, 1 To 1) As Long
b = 1
If bestX And 1 Then sel(1, 1) = 1
For i = 2 To n
    b = b * 2
    If bestX And b Then sel(i, 1) = 1
Next
r.Offset(0, 1) = sel
r(n).Offset(1, 1) = bestSum: r(n).Offset(1, 2) = "best"
r(n).Offset(2, 1) = targetSum: r(n).Offset(2, 2) = "target"
r(1).Offset(0, 1).EntireColumn.AutoFit
dt = Timer - st
DoEvents           ' avoid Windows anomaly (MsgBox does not display!)
MsgBox "done" & vbNewLine & cnt & " iterations" & _
    vbNewLine & Format(CDbl(dt), "0.000000") & " sec"
End Sub

Wow, let me wrap my head around this but it seems to be in the direction I'm trying to go. I'll do some tests and get back with you. Thanks for taking the time to explain your methods and theories.

 

[Eric W]

In the ancient days of this forum (2002!), there was a Challenge which was to solve this exact problem, given a list of various transactions, find a subset which sums to a given amount. The brute force method would be to check all 2^n combinations. However, the winning entry came up with an algorithm that was much more efficient. You can find the macro here:

https://www.mrexcel.com/challenges/accounts-receivable-challenge/

Sadly, if I recall correctly, it doesn't work as is, and there's no real instructions how to use it. But it's VERY close! As I recall, there was something about not reading the entries from the sheet right. I took that code and made a few minor tweaks and it worked wonderfully. I think anyone with a bit of VBA knowledge and some time could figure it out. I've wanted to clean it up a bit and post a commented version, but haven't got around to it.