Converting from Python Program, Finding combinations of elements that sum to target

MrQuestioner

New Member
Joined
Dec 14, 2022
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi guys, I am looking for a way to filter out elements from my column that adds up to a target sum, and I thought that I have found a great solution online from Combination of numbers that sum or match a target value. However, the program takes forever to load for negative values. I have found a python program online that works with negative values but I do not know how to convert it to work with vba.
Ideally, I want to be able to highlight a column of values and then be able to print on the right side of the column all possible combinations.Does anyone have any idea? Would appreciate any help I can get!

The Python program:
def subset(array, num):
result = []
def find(arr, num, path=()):
if not arr:
return
if arr[0] == num:
result.append(path + (arr[0],))
else:
find(arr[1:], num - arr[0], path + (arr[0],))
find(arr[1:], num, path)
find(array, num)
return result
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Not the same algorithm but does the same thing:
VBA Code:
Sub permutation()
  Dim lRow As Integer, targetValue As Integer
  lRow = Cells(Rows.Count, 1).End(xlUp).Row - 1
  ReDim inputt(lRow) As String
  ReDim outputt((2 ^ lRow) - 1, 1) As String
  targetValue = Cells(2, 2).Value
  For i = 2 To lRow + 1
    inputt(i - 2) = Cells(i, 1).Value
  Next

  For i = 0 To lRow - 1
    outputt((2 ^ i) - 1, 0) = inputt(i)
    outputt((2 ^ i) - 1, 1) = inputt(i)
    For ii = 0 To (2 ^ i) - 2
      outputt((2 ^ i) + ii, 0) = Application.Evaluate(outputt(ii, 0) & "+" & inputt(i))
      outputt((2 ^ i) + ii, 1) = CStr(outputt(ii, 1) & "+" & inputt(i))
    Next
  Next
  r = 1
  Application.ScreenUpdating = False
  For i = 1 To (2 ^ lRow) - 1
    If CInt(outputt(i - 1, 0)) = targetValue Then
      Cells(r, 3).Value = outputt(i - 1, 0)
      Cells(r, 4).Value = outputt(i - 1, 1)
      r = r + 1
    End If
  Next
  Application.ScreenUpdating = True
End Sub
1671038895357.png
 
Upvote 0
Solution
Thank you FlashBond. Thats a cool code! Can I make one more request? Could you edit the code so that it stops once it has found a permutation that sums up to the target? The code runs too long when there are many inputs so I would like it to be more efficient.
 
Upvote 0
Alright a quick look through the code and I was able to edit it to get just one permutation.

Here is the code:
VBA Code:
Sub permutation()
  Dim lRow As Long, targetValue As Double
  lRow = Cells(rows.count, 1).End(xlUp).row - 1
  ReDim inputt(lRow) As String
  ReDim outputt(CLng(2 ^ lRow) - 1, 1) As String
  targetValue = Cells(2, 2).value
  For i = 2 To lRow + 1
    inputt(i - 2) = Cells(i, 1).value
  Next

  For i = 0 To lRow - 1
    outputt((2 ^ i) - 1, 0) = inputt(i)
    outputt((2 ^ i) - 1, 1) = inputt(i)
    For ii = 0 To (2 ^ i) - 2
      outputt((2 ^ i) + ii, 0) = Application.Evaluate(outputt(ii, 0) & "+" & inputt(i))
      outputt((2 ^ i) + ii, 1) = CStr(outputt(ii, 1) & "+" & inputt(i))
      If CInt(outputt((2 ^ i) + ii, 0)) = targetValue Then
        Cells(1, 4).value = outputt((2 ^ i) + ii, 1)
        Exit Sub
      End If
    Next
  Next
'  R = 1
'Application.ScreenUpdating = False
'For i = 1 To (2 ^ lRow) - 1
'  If CInt(outputt(i - 1, 0)) = targetValue Then
'    Cells(R, 3).value = outputt(i - 1, 0)
'    Cells(R, 4).value = outputt(i - 1, 1)
'    Exit Sub
'    R = R + 1
'  End If
'Next
'Application.ScreenUpdating = True
End Sub
 
Upvote 0
Like this?
VBA Code:
Sub permutation()
  Dim lRow As Integer, targetValue As Integer
  Dim exitFor As Boolean
  exitFor = False
  lRow = Cells(Rows.Count, 1).End(xlUp).Row - 1
  ReDim inputt(lRow) As String
  ReDim outputt((2 ^ lRow) - 1, 1) As String
  targetValue = Cells(2, 2).Value
  For i = 2 To lRow + 1
    inputt(i - 2) = Cells(i, 1).Value
  Next

  For i = 0 To lRow - 1
    outputt((2 ^ i) - 1, 0) = inputt(i)
    outputt((2 ^ i) - 1, 1) = inputt(i)
    For ii = 0 To (2 ^ i) - 2
      outputt((2 ^ i) + ii, 0) = Application.Evaluate(outputt(ii, 0) & "+" & inputt(i))
      outputt((2 ^ i) + ii, 1) = CStr(outputt(ii, 1) & "+" & inputt(i))
      If CInt(outputt((2 ^ i) + ii, 0)) = targetValue Then
        exitFor = True
        Exit For
      End If
    Next
    If exitFor Then
      Exit For
    End If
  Next
  r = 1
  Application.ScreenUpdating = False
  For i = 1 To (2 ^ lRow) - 1
    If CInt(outputt(i - 1, 0)) = targetValue Then
      Cells(r, 3).Value = outputt(i - 1, 0)
      Cells(r, 4).Value = outputt(i - 1, 1)
      Exit For
      r = r + 1
    End If
  Next
  Application.ScreenUpdating = True
End Sub
 
Last edited by a moderator:
Upvote 0
Alright a quick look through the code and I was able to edit it to get just one permutation.

Here is the code:
VBA Code:
Sub permutation()
  Dim lRow As Long, targetValue As Double
  lRow = Cells(rows.count, 1).End(xlUp).row - 1
  ReDim inputt(lRow) As String
  ReDim outputt(CLng(2 ^ lRow) - 1, 1) As String
  targetValue = Cells(2, 2).value
  For i = 2 To lRow + 1
    inputt(i - 2) = Cells(i, 1).value
  Next

  For i = 0 To lRow - 1
    outputt((2 ^ i) - 1, 0) = inputt(i)
    outputt((2 ^ i) - 1, 1) = inputt(i)
    For ii = 0 To (2 ^ i) - 2
      outputt((2 ^ i) + ii, 0) = Application.Evaluate(outputt(ii, 0) & "+" & inputt(i))
      outputt((2 ^ i) + ii, 1) = CStr(outputt(ii, 1) & "+" & inputt(i))
      If CInt(outputt((2 ^ i) + ii, 0)) = targetValue Then
        Cells(1, 4).value = outputt((2 ^ i) + ii, 1)
        Exit Sub
      End If
    Next
  Next
'  R = 1
'Application.ScreenUpdating = False
'For i = 1 To (2 ^ lRow) - 1
'  If CInt(outputt(i - 1, 0)) = targetValue Then
'    Cells(R, 3).value = outputt(i - 1, 0)
'    Cells(R, 4).value = outputt(i - 1, 1)
'    Exit Sub
'    R = R + 1
'  End If
'Next
'Application.ScreenUpdating = True
End Sub
Ok. Glad it did work 👍
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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
Back
Top