![]() |
#2
|
||||
|
||||
![]()
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Nested Looping all combinations of four items | lhoffmeyer | Excel Programming | 1 | 11-30-2012 03:09 PM |
Excel eBay Fee Calculator Formula | rdonovan1 | Excel | 1 | 09-10-2012 07:37 PM |
Separate the digits into 3 combinations | Jasa P | Word VBA | 1 | 08-19-2012 11:04 PM |
Excel Calculator | Mandusin | Excel | 6 | 12-25-2010 07:34 AM |
Age Calculator in MS Outlook 2002 SP3 | turns | Outlook | 0 | 06-15-2010 12:26 AM |