I have found this great bit of code thank you "Tushar Mehta".

Is it possible to make it faster by only showing/working out 4 or less combinations any more and it will stop trying and move to next combination?

Been on it a while and cannot work it out.

Any help would be amazing

Thank you

Enter:

B2 - Solutions

B3 - Amount to match

B4 - Values for matching

C2 = 0

C3 = 124.12

C4:C16 = [TABLE="width: 64"]

<tbody>[TR]

[TD="width: 64, align: right"]0.12[/TD]

[/TR]

[TR]

[TD="align: right"]4[/TD]

[/TR]

[TR]

[TD="align: right"]13[/TD]

[/TR]

[TR]

[TD="align: right"]14[/TD]

[/TR]

[TR]

[TD="align: right"]15[/TD]

[/TR]

[TR]

[TD="align: right"]16[/TD]

[/TR]

[TR]

[TD="align: right"]17[/TD]

[/TR]

[TR]

[TD="align: right"]19[/TD]

[/TR]

[TR]

[TD="align: right"]20[/TD]

[/TR]

[TR]

[TD="align: right"]21.12[/TD]

[/TR]

[TR]

[TD="align: right"]100[/TD]

[/TR]

[TR]

[TD="align: right"]124.12[/TD]

[/TR]

[TR]

[TD="align: right"]24.12[/TD]

[/TR]

</tbody>[/TABLE]

Select C2:C16 then run macro and it will produce:

124.12, 1, 2, 9, 11

124.12, 2, 3, 4, 6, 7, 8, 9, 10

124.12, 3, 5, 6, 7, 8, 9, 13

124.12, 11, 13

124.12, 12

Next to speed it up some how and was thinking only running full loop if 4 or less combinations.

Code is:

Option Explicit

Function RealEqual(A, B, Optional Epsilon As Double = 0.00000001)

RealEqual = Abs(A - B) <= Epsilon

End Function

Function ExtendRslt(CurrRslt, NewVal, Separator)

If CurrRslt = "" Then ExtendRslt = NewVal _

Else ExtendRslt = CurrRslt & Separator & NewVal

End Function

Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _

ByVal HaveRandomNegatives As Boolean, _

ByVal CurrIdx As Integer, _

ByVal CurrTotal, ByVal Epsilon As Double, _

ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)

Dim I As Integer

For I = CurrIdx To UBound(InArr)

If RealEqual(CurrTotal + InArr(I), TargetVal, Epsilon) Then

Rslt(UBound(Rslt)) = (CurrTotal + InArr(I)) _

& Separator & ExtendRslt(CurrRslt, I, Separator)

If MaxSoln = 0 Then

If UBound(Rslt) Mod 100 = 0 Then Debug.Print "Rslt(" & UBound(Rslt) & ")=" & Rslt(UBound(Rslt))

Else

If UBound(Rslt) >= MaxSoln Then Exit Sub

End If

ReDim Preserve Rslt(UBound(Rslt) + 1)

ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(I) > TargetVal + Epsilon) Then

ElseIf CurrIdx < UBound(InArr) Then

recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _

I + 1, _

CurrTotal + InArr(I), Epsilon, Rslt(), _

ExtendRslt(CurrRslt, I, Separator), _

Separator

If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub

Else

'we've run out of possible elements and we _

still don't have a match

End If

Next I

End Sub

Function ArrLen(Arr()) As Integer

On Error Resume Next

ArrLen = UBound(Arr) - LBound(Arr) + 1

End Function

Function checkRandomNegatives(Arr) As Boolean

Dim I As Long

I = LBound(Arr)

Do While Arr(I) < 0 And I < UBound(Arr): I = I + 1: Loop

If I = UBound(Arr) Then Exit Function

Do While Arr(I) >= 0 And I < UBound(Arr): I = I + 1: Loop

checkRandomNegatives = Arr(I) < 0

End Function

Sub startSearch()

'The selection should be a single contiguous range in a single column. _

The first cell indicates the number of solutions wanted. Specify zero for all. _

The 2nd cell is the target value. _

The rest of the cells are the values available for matching. _

The output is in the column adjacent to the one containing the input data.

If Not TypeOf Selection Is Range Then GoTo ErrXIT

If Selection.Areas.Count > 1 Or Selection.Columns.Count > 1 Then GoTo ErrXIT

If Selection.Rows.Count < 3 Then GoTo ErrXIT

Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer, _

HaveRandomNegatives As Boolean

' StartTime = Now()

MaxSoln = Selection.Cells(1).Value

TargetVal = Selection.Cells(2).Value

InArr = Application.WorksheetFunction.Transpose( _

Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)

' HaveRandomNegatives = checkRandomNegatives(InArr)

If Not HaveRandomNegatives Then

ElseIf MsgBox("At least 1 negative number is present between positive numbers" _

& vbNewLine _

& "It may take a lot longer to search for matches." & vbNewLine _

& "OK to continue else Cancel", vbOKCancel) = vbCancel Then

Exit Sub

End If

ReDim Rslt(0)

recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _

LBound(InArr), 0, 0.00000001, _

Rslt, "", ", "

ReDim Preserve Rslt(UBound(Rslt) + 1)

Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _

Application.WorksheetFunction.Transpose(Rslt)

Exit Sub

ErrXIT:

MsgBox "Please select cells in a single column before using this macro" & vbNewLine _

& "The selection should be a single contiguous range in a single column." & vbNewLine _

& "The first cell indicates the number of solutions wanted. Specify zero for all." & vbNewLine _

& "The 2nd cell is the target value." & vbNewLine _

& "The rest of the cells are the values available for matching." & vbNewLine _

& "The output is in the column adjacent to the one containing the input data."

End Sub