The following macro checks all cell pairs and triplets in the selected rows and reports any that add up to the value stored in the nominated target cell. Finding all the combinations that add up to the maximum possible that is less than the target value adds a great deal more complexity.
Code:
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