=====================>>
Option Explicit
'This *REQUIRES* VBAProject references to
  'Microsoft Scripting Runtime
  'Microsoft VBScript Regular Expressions 1.0
  'Written by Harlan Grove


Sub FindSums()
  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
<<=================