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

[MrQuestioner]

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

 

[Legacy 143009]

Not the same algorithm but does the same thing:

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

 

[MrQuestioner]

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.

 

[MrQuestioner]

Alright a quick look through the code and I was able to edit it to get just one permutation.

Here is the 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

 

[Legacy 143009]

Like this?

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

 

[Legacy 143009]

Alright a quick look through the code and I was able to edit it to get just one permutation.

Here is the 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