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

 

[shg]

Without reading your code, on what basis do you want to determine the max number of items that sum to an exact total?

 

[Roderick_E]

Without reading your code, on what basis do you want to determine the max number of items that sum to an exact total?

=fact(range of invoices)

The basis is how many invoices are listed in range(A:A)

 

[shg]

You mean the factorial of the number of invoices? So if there were 20 invoices, you would check for combinations up to what size?

 

[Roderick_E]

You mean the factorial of the number of invoices? So if there were 20 invoices, you would check for combinations up to what size?

Yes, I know there will be a top level somewhere where the code would break, I'll deal with that somewhere later, but pretend Excel VBA can handle an infinite number

 

[shg]

Still don't see where factorial is relevant. The max number of combinations possible is 2^(number of invoices); every item either is or isn't in the combination.

 

[Roderick_E]

Still don't see where factorial is relevant. The max number of combinations possible is 2^(number of invoices); every item either is or isn't in the combination.

Ok maybe I'm wrong then. I'm not a math term wiz
For if you have 10 invoices and you have to loop through them and look at all possible combos, what would you call it?

 

[shg]

There are 2^10 = 1024 combinations, from none to all.

 

[Rick Rothstein]

I know the OP was mistaken in looking for large factorials, but given the thread title, I figured others might come here in the future looking for a way to do large factorials. For those people, here is a function I developed many years ago which will accurately return factorials for up to the number 31 whose factorial is 8222838654177922817725562880000000 (for higher numbers, it will return an approximate result using powers of 10 notation)...

Function BigFactorial(N As Long) As Variant
  Dim X As Long
  If N < 28 Then
    BigFactorial = CDec(1)
    For X = 1 To N
      BigFactorial = X * BigFactorial
    Next
  ElseIf N > 31 Then
    BigFactorial = CDbl(1)
    For X = 1 To N
      BigFactorial = X * BigFactorial
    Next
  Else
    BigFactorial = CDec("10888869450418352160768")
    For X = 28 To N
      BigFactorial = X * BigFactorial
    Next
    BigFactorial = BigFactorial & "000000"
  End If
End Function

 

[joeu2004]

The max number of combinations possible is 2^(number of invoices); every item either is or isn't in the combination

Ok [....] For if you have 10 invoices and you have to loop through them and look at all possible combos, what would you call it?

"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.

Can someone please figure out how to make my code dynamic?

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