Sub FindSubSets()
Application.ScreenUpdating = False
Dim a As Long, b As Long, c As Long, d As Long
Dim Target As String, Output As String
Dim x As Long, y As Long, z As Long
If Selection.Rows.Count = 1 Or Selection.Columns.Count <> 1 Then
  MsgBox "Please select more than one row in a single column"
  Exit Sub
End If
a = ActiveCell.Row
b = ActiveCell.Column
c = Selection.Rows.Count + ActiveCell.Row - 1
d = 0
Target = InputBox("What is the address of the cell" & vbCrLf & "you want the numbers to add up to?")
Output = InputBox("What is the address of the first cell" & vbCrLf & "you want to output the results in?")
On Error GoTo Abort
Range(Output).Offset(d, 0) = ""
For x = a To c
  For y = x + 1 To c
  If Cells(x, b) + Cells(y, b) = Range(Target).Value Then
    Range(Output).Offset(d, 0) = Addr(x, b) + "+" + Addr(y, b)
    d = d + 1
  Else
    For z = y + 1 To c
    If Cells(x, b) + Cells(y, b) + Cells(z, b) = Range(Target).Value Then
      Range(Output).Offset(d, 0) = Addr(x, b) + "+" + Addr(y, b) + "+" + Addr(z, b)
      d = d + 1
    End If
    Next z
  End If
  Next y
Next x
Range(Output).Offset(d, 0) = ""
Abort:
Application.ScreenUpdating = False
End Sub
Private Function Addr(ByVal n As Long, ByVal m As Long) As String
  Addr = Cells(n, m).Address(False, False)
End Function