How to find the combination of numbers that equal to value n

[Luthius]

Hello guys
I found a very usefull code and I would like your assistance on implement it on limitating the quantity of numbers that will give the desired sum.
For instance I would like the combination of numbers limitating to 13 the set of numbers.
So I will have for each set of numbers 13 numbers as example.
I will choose the quantity of sets and also the quantity of number in each set that will give me as sum result my desired value.

Option Explicit 
Function RealEqual(A, B, Epsilon As Double)
    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 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 & Format(Now(), "hh:mm:ss") _
            & Separator & ExtendRslt(CurrRslt, I, Separator)
            If MaxSoln = 0 Then
                If UBound(Rslt) Mod 100 = 0 Then Debug.Print UBound(Rslt) & "=" & Rslt(UBound(Rslt))
            Else
                If UBound(Rslt) >= MaxSoln Then Exit Sub
            End If
            ReDim Preserve Rslt(UBound(Rslt) + 1)
        ElseIf CurrTotal + InArr(I) > TargetVal + Epsilon Then
        ElseIf CurrIdx < UBound(InArr) Then
            recursiveMatch MaxSoln, TargetVal, InArr(), 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

Source:

http://www.tushar-mehta.com/excel/templates/match_values/

 

[Luthius]

Searching on the internet I found the code below that I changed. Now everything is working as my needs. Sorting from left to right within the cell.

Thanks again for your help.

Public Function CellSort(r As Range) As String    Dim bry() As Long, L As Long, U As Long, ch As String
    ch = r(1).Text
    ary = Split(ch, "+")
    L = LBound(ary)
    U = UBound(ary)
    ReDim bry(L To U)
    For i = LBound(ary) To UBound(ary)
        bry(i) = CLng(ary(i))
    Next i


    Call BubbleSort(bry)


    For i = LBound(bry) To UBound(bry)
        ary(i) = CStr(bry(i))
    Next i
    CellSort = Join(ary, "+")
End Function

Sub BubbleSort(arr)
    Dim strTemp As Variant
    Dim i As Long
    Dim j As Long
    Dim lngMin As Long
    Dim lngMax As Long
    lngMin = LBound(arr)
    lngMax = UBound(arr)
    For i = lngMin To lngMax - 1
        For j = i + 1 To lngMax
            If arr(i) > arr(j) Then
                strTemp = arr(i)
                arr(i) = arr(j)
                arr(j) = strTemp
            End If
        Next j
    Next i
End Sub

 

[shg]

Good job, you're welcome.