PDA

View Full Version : Conditional VBA for Combinations



swalk88
12-14-2017, 03:35 PM
Hi,

I am trying to create a number of combinations that add up to a certain number. I.e.



25
25
25




50
50
50




75
75
75





If I have the above table and my target is 100, I want the code to loop through the combinations until it gets to 100 and then move to the next one.

Logical process is as below:
25 - 25 - 25 = 75 (not 100 so ignores)
25 - 25 - 50 = 100 (keeps this result)
25 - 25 - 75 = 125 (not 100 so ignores)
25 - 50 - 25 = 100 (keeps this result)
....

I have found the following code, just need assistance to get it to overwrite if the sum of the columns isn't 100.


Sub combinations()

Dim c1() As Variant
Dim c2() As Variant
Dim c3() As Variant
Dim c4() As Variant
Dim c5() As Variant
Dim out() As Variant
Dim j As Long, k As Long, l As Long, m As Long, n As Long, o As Long




Dim col1 As Range
Dim col2 As Range
Dim col3 As Range
Dim col4 As Range
Dim col5 As Range
Dim out1 As Range




Set col1 = Range("A1", Range("A1").End(xlDown))
Set col2 = Range("B1", Range("B1").End(xlDown))
Set col3 = Range("C1", Range("C1").End(xlDown))
Set col4 = Range("D1", Range("D1").End(xlDown))
Set col5 = Range("E1", Range("E1").End(xlDown))


c1 = col1
c2 = col2
c3 = col3
c4 = col4
c5 = col5


Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4) * UBound(c5)))
out = out1


j = 1
k = 1
l = 1
m = 1
n = 1
o = 1


Do While j <= UBound(c1)
Do While k <= UBound(c2)
Do While l <= UBound(c3)
Do While m <= UBound(c4)
Do While n <= UBound(c5) ' This now loops correctly
out(o, 1) = c1(j, 1)
out(o, 2) = c2(k, 1)
out(o, 3) = c3(l, 1)
out(o, 4) = c4(m, 1)
out(o, 5) = c5(n, 1)
o = o + 1
n = n + 1
Loop
n = 1
m = m + 1
Loop
m = 1
l = l + 1
Loop
l = 1
k = k + 1
Loop
k = 1
j = j + 1
Loop




out1.Value = out
End Sub

Thanks, in advance

swalk88
12-14-2017, 04:45 PM
Further to the above, I would like to specify that the combinations must be made with a value from each of the column. The code works fine for me except that it returns all results rather than just ones that equal 100.

Many thanks.

MINCUS1308
12-21-2017, 10:33 AM
EH?


Sub FUN()
Dim ValidCombinations()
POS = 1

Dim EntireDataSet()
EntireDataSet = Range("A1").CurrentRegion

ReDim TestCombination(1 To UBound(EntireDataSet, 2)) As Variant

For MyCol = 2 To UBound(EntireDataSet, 2)
For R = 1 To UBound(EntireDataSet, 1)
For C = 1 To UBound(EntireDataSet, 2)
TestCombination(C) = EntireDataSet(R, C)
Next C

For I = 1 To UBound(EntireDataSet, 1)
TestCombination(MyCol) = EntireDataSet(I, MyCol)

CombinationSum = 0
For A = 1 To UBound(TestCombination)
CombinationSum = TestCombination(A) + CombinationSum
Next A

If CombinationSum = 100 Then
On Error Resume Next
ExistingEntry = (UBound(Filter(ValidCombinations, Join(TestCombination, ", "))) > -1)
On Error GoTo 0
If Not ExistingEntry Then
ReDim Preserve ValidCombinations(0 To POS + 1)
ValidCombinations(POS) = Join(TestCombination, ", ")
POS = POS + 1
End If
Else
'MsgBox "FAILED COMBINATION"
End If
Next I
Next R
Next MyCol

MsgBox Join(ValidCombinations, " | ")

End Sub


HERE IS MY TEST FILE: 21228

MINCUS1308
12-21-2017, 10:36 AM
That really pushed my coding abilities lol.
sorry for making you wait like that, I didn't see this post till today.

hopefully that's what you were trying to do

MINCUS1308
12-21-2017, 02:34 PM
Realized I made a mistake.
Here's the corrected file: 21229
And the code:


Sub FUN()
Dim ValidCombinations()
POS = 1

Dim EntireDataSet()
EntireDataSet = Range("A1").CurrentRegion

'STARTING DATA SET
ReDim TestCombination(1 To UBound(EntireDataSet, 2)) As Variant

For MyCol = 1 To UBound(EntireDataSet, 2)
For R = 1 To UBound(EntireDataSet, 1)
For C = 1 To UBound(EntireDataSet, 2)
TestCombination(C) = EntireDataSet(R, C)
Next C

For I = 1 To UBound(EntireDataSet, 1)
TestCombination(MyCol) = EntireDataSet(I, MyCol)

CombinationSum = 0
For A = 1 To UBound(TestCombination)
CombinationSum = TestCombination(A) + CombinationSum
Next A

If CombinationSum = 100 Then
On Error Resume Next
ExistingEntry = (UBound(Filter(ValidCombinations, Join(TestCombination, ", "))) > -1)
On Error GoTo 0
If Not ExistingEntry Then
ReDim Preserve ValidCombinations(0 To POS + 1)
ValidCombinations(POS) = Join(TestCombination, ", ")
POS = POS + 1
End If
Else
'MsgBox "COMBINATIONS VALUE <> 100"
End If
Next I
Next R
Next MyCol

MsgBox Join(ValidCombinations, " | ")

End Sub