# Find set of amounts that match target value

#### KitNovice

##### New Member
Hi all,

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 =
 0.12 4 13 14 15 16 17 19 20 21.12 100 124.12 24.12

<tbody>
</tbody>

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

### Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Replies
4
Views
2K
Replies
0
Views
606
Replies
5
Views
2K
Replies
3
Views
754
Replies
21
Views
2K

1,196,073
Messages
6,013,267
Members
441,758
Latest member
Abren

### 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.

### Which adblocker are you using?

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

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