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:
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