Factorial total number finding loop

Roderick_E

Well-known Member
Joined
Oct 13, 2007
Messages
2,051
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:
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
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,787
Office Version
  1. 2010
Platform
  1. Windows
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

Well-known Member
Joined
Oct 13, 2007
Messages
2,051
Without reading your code, on what basis do you want to determine the max number of items that sum to an exact total?

Code:
=fact(range of invoices)

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

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,787
Office Version
  1. 2010
Platform
  1. Windows
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

Well-known Member
Joined
Oct 13, 2007
Messages
2,051

ADVERTISEMENT

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

MrExcel MVP
Joined
May 7, 2008
Messages
21,787
Office Version
  1. 2010
Platform
  1. Windows
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

Well-known Member
Joined
Oct 13, 2007
Messages
2,051

ADVERTISEMENT

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

MrExcel MVP
Joined
May 7, 2008
Messages
21,787
Office Version
  1. 2010
Platform
  1. Windows
There are 2^10 = 1024 combinations, from none to all.
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
37,030
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
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)...
Code:
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

Well-known Member
Joined
Mar 2, 2014
Messages
3,053
Office Version
  1. 2010
Platform
  1. Windows
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(n). 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.

Code:
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
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,132,671
Messages
5,654,659
Members
418,146
Latest member
Shnn028

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top