Kind regards,

Niek Otten
Microsoft MVP - Excel

     Find numbers that add up to a specified sum.
     Niek Otten
     05-Apr-06

     This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited
     set of data
     One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by Harlan
Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value exactly,
it will miss that combination. I don't know if this has been corrected later.
     Note the requirements for your settings documented in the code itself

     Peo's solution:
     ==================================================
     One way but you need the solver add-in installed (it comes with
     excel/office,check under tools>add-ins)
     put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc}
     in the adjacent cells
     in C2 put 8, in D2 put
     =SUMPRODUCT(A2:A7,B2:B7)
     select D2 and do tools>solver, set target cell $D$2 (should come up
     automatically if selected)
     Equal to a Value of 8, by changing cells $B$2:$B$7, click add under  Subject
     to the constraints of:
     in Cell reference put
     $B$2:$B$7
     from dropdown select Bin, click OK and click Solve, Keep solver solution
     and look at the table
     2         1
     4         0
     5         0
     6         1
     9         0
     13       0
     there you can see that 4 ones have been replaced by zeros and the adjacent
     cells to the 2 ones
     total 8
     --
     Regards,
     Peo Sjoblom
     ==================================================
     Harlan's solution:

     'Begin VBA Code

     ' By Harlan Grove

     Sub findsums()
     'This *REQUIRES* VBAProject references to
       'Microsoft Scripting Runtime
       'Microsoft VBScript Regular Expressions 1.0 or higher

       Const TOL As Double = 0.000001  'modify as needed
       Dim c As Variant

       Dim j As Long, k As Long, n As Long, p As Boolean
       Dim s As String, t As Double, u As Double
       Dim v As Variant, x As Variant, y As Variant
       Dim dc1 As New Dictionary, dc2 As New Dictionary
       Dim dcn As Dictionary, dco As Dictionary
       Dim re As New RegExp

       re.Global = True
       re.IgnoreCase = True

       On Error Resume Next

       Set x = Application.InputBox( _
         Prompt:="Enter range of values:", _
         Title:="findsums", _
         Default:="", _
         Type:=8 _
       )

       If x Is Nothing Then
         Err.Clear
         Exit Sub
       End If

       y = Application.InputBox( _
         Prompt:="Enter target value:", _
         Title:="findsums", _
         Default:="", _
         Type:=1 _
       )

       If VarType(y) = vbBoolean Then
         Exit Sub
       Else
         t = y
       End If

       On Error GoTo 0

       Set dco = dc1
       Set dcn = dc2

       Call recsoln

       For Each y In x.Value2
         If VarType(y) = vbDouble Then
           If Abs(t - y) < TOL Then
             recsoln "+" & Format(y)

           ElseIf dco.Exists(y) Then
             dco(y) = dco(y) + 1

           ElseIf y < t - TOL Then
             dco.Add Key:=y, Item:=1

             c = CDec(c + 1)
             Application.StatusBar = "[1] " & Format(c)

           End If

         End If
       Next y

       n = dco.Count

       ReDim v(1 To n, 1 To 3)

       For k = 1 To n
         v(k, 1) = dco.Keys(k - 1)
         v(k, 2) = dco.Items(k - 1)
       Next k

       qsortd v, 1, n

       For k = n To 1 Step -1
         v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
         If v(k, 3) > t Then dcn.Add Key:="+" & _
           Format(v(k, 1)), Item:=v(k, 1)
       Next k

       On Error GoTo CleanUp
       Application.EnableEvents = False
       Application.Calculation = xlCalculationManual

       For k = 2 To n
         dco.RemoveAll
         swapo dco, dcn

         For Each y In dco.Keys
           p = False

           For j = 1 To n
             If v(j, 3) < t - dco(y) - TOL Then Exit For
             x = v(j, 1)
             s = "+" & Format(x)
             If Right(y, Len(s)) = s Then p = True
             If p Then
               re.Pattern = "\" & s & "(?=(\+|$))"
               If re.Execute(y).Count < v(j, 2) Then
                 u = dco(y) + x
                 If Abs(t - u) < TOL Then
                   recsoln y & s
                 ElseIf u < t - TOL Then
                   dcn.Add Key:=y & s, Item:=u
                   c = CDec(c + 1)
                   Application.StatusBar = "[" & Format(k) & "] " & _
                       Format(c)
                 End If
               End If
             End If
           Next j
         Next y

         If dcn.Count = 0 Then Exit For
       Next k

       If (recsoln() = 0) Then _
         MsgBox Prompt:="all combinations exhausted", _
           Title:="No Solution"

     CleanUp:
       Application.EnableEvents = True
       Application.Calculation = xlCalculationAutomatic
       Application.StatusBar = False

     End Sub

     Private Function recsoln(Optional s As String)
       Const OUTPUTWSN As String = "findsums solutions"  'modify to taste

       Static r As Range
       Dim ws As Worksheet

       If s = "" And r Is Nothing Then
         On Error Resume Next
         Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
         If ws Is Nothing Then
           Err.Clear
           Application.ScreenUpdating = False
           Set ws = ActiveSheet
           Set r = Worksheets.Add.Range("A1")
           r.Parent.Name = OUTPUTWSN
           ws.Activate
           Application.ScreenUpdating = False
         Else
           ws.Cells.Clear
           Set r = ws.Range("A1")
         End If
         recsoln = 0
       ElseIf s = "" Then
         recsoln = r.Row - 1
         Set r = Nothing
       Else
         r.Value = s
         Set r = r.Offset(1, 0)
         recsoln = r.Row - 1
       End If
     End Function

     Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
       'ad hoc quicksort subroutine
       'translated from Aho, Weinberger & Kernighan,
       '"The Awk Programming Language", page 161

       Dim j As Long, pvt As Long

       If (lft >= rgt) Then Exit Sub
       swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
       pvt = lft
       For j = lft + 1 To rgt
         If v(j, 1) > v(lft, 1) Then
           pvt = pvt + 1
           swap2 v, pvt, j
         End If
       Next j

       swap2 v, lft, pvt

       qsortd v, lft, pvt - 1
       qsortd v, pvt + 1, rgt
     End Sub

     Private Sub swap2(v As Variant, i As Long, j As Long)
       'modified version of the swap procedure from
       'translated from Aho, Weinberger & Kernighan,
       '"The Awk Programming Language", page 161

       Dim t As Variant, k As Long

       For k = LBound(v, 2) To UBound(v, 2)
         t = v(i, k)
         v(i, k) = v(j, k)
         v(j, k) = t
       Next k
     End Sub

     Private Sub swapo(a As Object, b As Object)
       Dim t As Object

       Set t = a
       Set a = b
       Set b = t
     End Sub
     '---- end VBA code ----