```
Option Explicit
Option Compare Text
Public Sub CombineNumbers()
Application.Calculation = xlCalculationManual
Dim arrAllNumbers() As Single
Dim arrCurrentNumbers() As Single
Dim arrResults() As Single
Dim RunningSum As Single
Dim TargetValue As Single
Dim i As Integer, j As Integer, k As Integer
Dim rng As Range
On Error GoTo errHandler
TargetValue = Range("C2").Value
Set rng = Range("A2").Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
ReDim arrAllNumbers(1 To rng.Rows.Count, 1)
ReDim arrCurrentNumbers(1 To UBound(arrAllNumbers, 1), 1)
arrAllNumbers = rng
' Range("B2").Resize(UBound(arrAllNumbers, 1)) = arrAllNumbers
For i = 1 To UBound(arrAllNumbers, 1)
If arrAllNumbers(i) = TargetValue Then
End If
Next i
exitPoint:
Set rng = Nothing
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = "READY"
Exit Sub
errHandler:
MsgBox "Error occurred. " & vbCrLf & "Number: " & Err.Number & vbCrLf & Err.Description, _
vbInformation + vbOKOnly
Resume exitPoint
End Sub
Function ListPermut(num As Integer)
'Permutations without repetition
Dim c As Long, r As Long, p As Long
Dim rng() As Long, temp As Long, i As Long
Dim temp1 As Long, y() As Long, d As Long
p = WorksheetFunction.Permut(num, num)
' Create array
ReDim rng(1 To p, 1 To num)
'Create first row in array (1, 2, 3, ...)
For c = 1 To num
rng(1, c) = c
Next c
For r = 2 To p
' 1. Find the first smaller number rng(r-1, c-1)<rng(r-1,c)
For c = num To 1 Step -1
If rng(r - 1, c - 1) < rng(r - 1, c) Then
temp = c - 1
Exit For
End If
Next c
' Copy values from previous row
For c = num To 1 Step -1
rng(r, c) = rng(r - 1, c)
Next c
' 2. Find a larger number than rng(r-1, temp)as far to the right as possible
For c = num To 1 Step -1
If rng(r - 1, c) > rng(r - 1, temp) Then
temp1 = rng(r - 1, temp)
rng(r, temp) = rng(r - 1, c)
rng(r, c) = temp1
ReDim y(num - temp)
i = 0
For d = temp + 1 To num
y(i) = rng(r, d)
i = i + 1
Next d
i = 0
For d = num To temp + 1 Step -1
rng(r, d) = y(i)
i = i + 1
Next d
Exit For
End If
Next c
Next r
ListPermut = rng
End Function
' PGC Oct 2007
' Calculates a Power Set
' Set in A1, down. Result in C1, down and accross. Clears C:Z.
Public Sub PowerSet()
Application.Calculation = xlCalculationManual
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long
Dim vTarget As Single
vTarget = Range("B2").Value
vElements = Application.Transpose(Range("A2", Range("A2").End(xlDown)))
Columns("D:ZZ").ClearContents
lRow = 1
For i = 1 To UBound(vElements)
ReDim vresult(1 To i)
Application.StatusBar = "Calculating combinations of " & i & " number(s)"
Call CombinationsNP(vElements, i, vresult, lRow, 1, 1, vTarget)
Next i
Debug.Print "done"
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = "READY"
End Sub
Sub CombinationsNP(vElements As Variant, p As Long, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer, Optional targetSum As Single = 0)
Dim i As Long
Dim jRow As Long
Dim kCol As Long
Dim runSum As Single
Dim vResult2() As Variant
For i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
runSum = 0
For jRow = LBound(vresult) To UBound(vresult)
runSum = runSum + vresult(jRow)
' Debug.Print vresult(jRow),
Next jRow
' Debug.Print runSum
If runSum = targetSum Then
lRow = lRow + 1
Range("B4").Offset(, lRow).Resize(p) = Application.Transpose(vresult)
End If
Else
Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1, targetSum)
End If
Next i
End Sub
```