"Lawrence" wrote:
Tushar,
thanks for your great help, but the template does work perfectly. may i can
elaborate more as below for your better understanding
DO# Delivered qty
1a 123
2a 234
3a 567
4a 123
5a 245
so my target is 246 qty, can i using formula so that i can know which DO can
make up 246 qty? answer: 1a + 4a
Lawrence
I have not seen Tusha's template but it seems that you want to find
combinations that reach a target i.e. singles, doubles et al. This takes
forever, especially when you look for five combinations or more and requires
a macro.
The following procedures examines data in column B and enters the
combinations in columns D and E, also the target figure is placed in A7.
I would copy your data into a blank workbook before trying this, it will
delete the information in columns D and E (and any adjacent columns) - make a
cup of coffee while you wait!
I'll send you a copy of the test sheet if you want to see it. mail at
peter_atherton at hotmail dot com
regards
Peter
Copy the following into a
VB module
Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, x As Double, z As Integer
Dim row As Long, count As Long, lr As Long
Dim r As Long, col As Integer, rng
Private Sub getRange()
x = InputBox("Enter the target Number", "Target Sums", 0#)
r = ActiveCell.row
col = ActiveCell.Column
Range("A7") = x
With ActiveSheet
rng = Cells(r, col).Address
End With
y = InputBox("Enter the range", "Enter Data range", rng)
Range(y).Select
lr = Selection.Rows.count
ActiveCell.Select
End Sub
Sub unit()
Dim startTime As Date, EndTime As Date, TimeTaken As Date
Range("D3").CurrentRegion.ClearContents
getRange
Application.StatusBar = "Combinations Running! Please wait...."
Application.ScreenUpdating = False
row = 3: count = 0
'------Remove the next line when ready------
startTime = Now
'--------------------
For i = 1 To lr
y = CCur(Cells(i, 2))
If y = CCur(x) Then
'this line can be remmed out so sums are not shown
Cells(row, 4) = Cells(i, 2)
' alternatively, this line showing cells can be remmed out
Cells(row, 5) = Cells(i, 2).Address(RowAbsolute:=False, _
columnabsolute:=False)
row = row + 1: count = count + 1
End If
Next i
Doubles
Columns("D:E").EntireColumn.AutoFit
Application.ScreenUpdating = True
'--------Remove these lines when ready---------
EndTime = Now
TimeTaken = EndTime - startTime
MsgBox TimeTaken, vbInformation, "Time Taken to complete procedure"
MsgBox count, vbInformation, "Total Number of combinations"
'---------------------------------------------
Application.StatusBar = ""
End Sub
Private Sub Doubles()
row = 3
For i = 1 To lr - 1
For z = lr To 2 Step -1
y = CCur(Cells(i, 2) + Cells(z, 2))
If y = CCur(x) And i < z And Cells(i, 2) < 0 Then
'this line can be remmed out so sums are not shown
Cells(row, 4) = Cells(i, 2) & "+" & Cells(z, 2)
' alternatively, this line showing cells can be remmed out
Cells(row, 5) = Cells(i, 2).Address(RowAbsolute:=False, _
columnabsolute:=False) & "+" & Cells(z, 2).Address(RowAbsolute:=False,
columnabsolute:=False)
row = row + 1: count = count + 1
End If
Next
Next
Trebles
End Sub
Private Sub Trebles()
For i = 1 To lr - 2
For j = 2 To lr - 1
For z = lr To 2 Step -1
y = CCur(Cells(i, 2) + Cells(j, 2) + Cells(z, 2))
If y = CCur(x) And _
i < j And j < z And Cells(i, 2) < 0 And Cells(j, 2) < 0 And
Cells(z, 2) < 0 Then
' this line can be remmed out so sums are not shown
Cells(row, 4) = Cells(i, 2) & "+" & Cells(j, 2) & "+" & Cells(z, 2)
' alternatively, this line showing cells can be remmed out
Cells(row, 5) = Cells(i, 2).Address(RowAbsolute:=False, _
columnabsolute:=False) & "+" & Cells(j,
2).Address(RowAbsolute:=False, _
columnabsolute:=False) & "+" & Cells(z,
2).Address(RowAbsolute:=False, columnabsolute:=False)
row = row + 1: count = count + 1
End If
Next z
Next j
Next i
quads
End Sub
Private Sub quads()
For i = 1 To lr - 3
For j = 2 To lr - 2
For k = 3 To lr - 1
For z = lr To 3 Step -1
y = CCur(Cells(i, 2) + Cells(j, 2) + Cells(k, 2) + Cells(z, 2))
If y = CCur(x) And _
i < j And j < k And k < z And Cells(i, 2) < 0 And Cells(j, 2) <
0 _
And Cells(k, 2) < 0 And Cells(z, 2) < 0 Then
'this line can be remmed out so sums are not shown
Cells(row, 4) = Cells(i, 2) & "+" & Cells(j, 2) & "+" & Cells(k,
2) _
& "+" & Cells(z, 2)
' alternatively, this line showing cells can be remmed out
Cells(row, 5) = Cells(i, 2).Address(RowAbsolute:=False,
columnabsolute:=False) _
& "+" & Cells(j, 2).Address(RowAbsolute:=False,
columnabsolute:=False) & _
"+" & Cells(k, 2).Address(RowAbsolute:=False,
columnabsolute:=False) & _
"+" & Cells(z, 2).Address(RowAbsolute:=False,
columnabsolute:=False)
row = row + 1: count = count + 1
End If
Next z
Next k
Next j
Next i
Quins
End Sub
Private Sub Quins()
' The procedure really slows at this point
' to stop this macro running you need to rem it out;
' just type an apostrophe before quins in the last macro
' second line from end
For i = 1 To lr - 4
For j = 2 To lr - 3
For k = 3 To lr - 2
For l = 4 To lr - 1
For z = lr To 4 Step -1
y = CCur(Cells(i, 2) + Cells(j, 2) + Cells(k, 2) + Cells(l, 2) +
Cells(z, 2))
If y = CCur(x) And _
i < j And j < k And k < l And l < z And Cells(i, 2) < 0 And
Cells(j, 2) < 0 _
And Cells(k, 2) < 0 And Cells(l, 2) < 0 And Cells(z, 2) < 0
Then
' this line can be remmed out so sums are not shown
Cells(row, 4) = Cells(i, 2) & "+" & Cells(j, 2) & "+" &
Cells(k, 2) _
& "+" & Cells(l, 2) & "+" & Cells(z, 2)
' alternatively, this line showing cells can be remmed out
Cells(row, 5) = Cells(i, 2).Address(RowAbsolute:=False,
columnabsolute:=False) _
& "+" & Cells(j, 2).Address(RowAbsolute:=False,
columnabsolute:=False) & _
"+" & Cells(k, 2).Address(RowAbsolute:=False,
columnabsolute:=False) & _
"+" & Cells(l, 2).Address(RowAbsolute:=False,
columnabsolute:=False) _
& "+" & Cells(z, 2).Address(RowAbsolute:=False,
columnabsolute:=False)
row = row + 1: count = count + 1
End If
Next z
Next l
Next k
Next j
Next i
sextet
End Sub
Private Sub sextet()
For i = 1 To lr - 5
For j = 2 To lr - 4
For k = 3 To lr - 3
For l = 4 To lr - 2
For m = 5 To lr - 1
For z = lr To 5 Step -1
y = CCur(Cells(i, 2) + Cells(j, 2) + Cells(k, 2) + Cells(l, 2) + _
Cells(m, 2) + Cells(z, 2))
If y = CCur(x) And i < j And j < k And k < l And l < m And m < z _
And Cells(i, 2) < 0 And Cells(j, 2) < 0 _
And Cells(k, 2) < 0 And Cells(l, 2) < 0 And Cells(z, 2) < 0
Then
' this line can be remmed out so sums are not shown
Cells(row, 4) = Cells(i, 2) & "+" & Cells(j, 2) & "+" &
Cells(k, 2) _
& "+" & Cells(l, 2) & "+" & Cells(m, 2) & "+" & Cells(z, 2)
Cells(row, 5) = Cells(i, 2).Address(RowAbsolute:=False,
columnabsolute:=False) _
& "+" & Cells(j, 2).Address(RowAbsolute:=False,
columnabsolute:=False) & _
"+" & Cells(k, 2).Address(RowAbsolute:=False,
columnabsolute:=False) & _
"+" & Cells(l, 2).Address(RowAbsolute:=False,
columnabsolute:=False) & _
"+" & Cells(m, 2).Address(RowAbsolute:=False,
columnabsolute:=False) _
& "+" & Cells(z, 2).Address(RowAbsolute:=False,
columnabsolute:=False)
row = row + 1: count = count + 1
End If
Next z
Next m
Next l
Next k
Next j
Next i
End Sub
'============= End of
VB Code ==================