Re: Calculate Sets and Subsets
Hi, I am a newbie trying to code some ideas about sets and subsets, the code I will attach here, generate all possible combination of 24 numbers taken 6 at time and some direction apply. My problem or question is there are some definition out of my knolege (newbie), you can input how many odds and evens numbers, and sum range. Now what I really want to do is to import or storage a list of 2200 numbers in the code, so the new numbers generate by the code has to be compare and if find duplicate from the old list just delete, also from the sum range I want to turn off some values.
Code:
Option Explicit
'Various definitions requested
'1)odds and even will be input
'2)18 sum values will be avoid from the range
'3)a list of combinations to avoid will be input and storage
'4)the lis of combinations to avoid will be update any time
'5)the index number combination will be show
'6)Successful output ->sum range ->21 to 303 ->only those sum to these inclusive include in output
'=================================================================================================
'current definition are No. 1 and 6
'=================================================================================================
Public sumArr As Long, oddNo As Long, evenNo As Long, t As Long, oddNoReq As Long, lastRow As Long, _
evenNoReq As Long, minSumValue As Long, maxSumValue As Long, lRow As Long, testRow As Long, m As Long, minMaxRn As Long
Sub filtercombinations()
On Error GoTo errHandler
sortDataFirst
'********************************************************************************************************************************
'initialise variables
sumArr = 0: oddNo = 0: evenNo = 0: oddNoReq = 0: lastRow = 0: evenNoReq = 0: minSumValue = 0
maxSumValue = 0: lRow = 0: testRow = 0: m = 0: minMaxRn = 0
'Validate Data Entry Combination Definitions
If Range("B34") = vbNullString Or Range("B35") = vbNullString Or Range("B37") = vbNullString Or Range("B38") = vbNullString Then
MsgBox " enter the Number of Evens/Odds required in combination and the " & _
"Minimum Sum Value and Maximum Sum Value", vbExclamation
Exit Sub
End If
If Range("B37").Value > Range("B38").Value Then
MsgBox "The Minimum Sum must be less or iqual to the Maximum Sum", vbExclamation
Exit Sub
End If
If Range("B34").Value + Range("B35").Value <> 6 Then
MsgBox "You have entered an invalid combination of Even and Odd Numbers", vbExclamation
Exit Sub
End If
'Check max and min sum values
lastRow = lastRwCt
For m = 1 To 6
minMaxRn = minMaxRn + Cells(m, 1).Value
Next
If Range("B37").Value < minMaxRn Then
MsgBox "You have entered an invalid Sum Minimum value in the Combination Ouput Definition", vbExclamation
minMaxRn = 0
Exit Sub
End If
minMaxRn = 0
For m = lastRow - 5 To lastRow
minMaxRn = minMaxRn + Cells(m, 1).Value
Next
If Range("B38").Value > minMaxRn Then
MsgBox "You have entered an invalid Sum Maximum value in the Combination Ouput Definition", vbExclamation
minMaxRn = 0
Exit Sub
End If
'Data is valid - Set Requirements
oddNoReq = Range("B34")
evenNoReq = Range("B35")
minSumValue = Range("B37")
maxSumValue = Range("B38")
'********************************************************************************************************************************
Dim rRng As Range, p As Integer
Dim vElements, vresult As Variant
lRow = 1: testRow = 1
Set rRng = Range("A1", Range("A1").End(xlDown))
rRng.Select
p = 6
Dim q As Integer
Dim b As Double
b = 1
For q = 0 To p - 1
b = b * (lastRow - q) / (p - q)
Next q
MsgBox "No of Non repeating combinations is -> " & b, vbInformation
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
Columns("C").Resize(, p + 15).Clear
headingsInsert
Call CombinationsNP(vElements, p, vresult, lRow, 1, 1)
MsgBox "There are " & lRow - 1 & " combinations that meet your output definition", vbInformation
Exit Sub
errHandler:
MsgBox "Error has occured - error no " & Err.Number & " - " & Err.Description
End Sub
Sub CombinationsNP(vElements As Variant, p As Integer, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer, k As Integer
On Error GoTo errHandler
For i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
'test array vresult for conditions as defined in data entry
For k = LBound(vresult) To UBound(vresult)
If vresult(k) Mod 2 <> 0 Then oddNo = oddNo + 1
If vresult(k) Mod 2 = 0 Then evenNo = evenNo + 1
sumArr = sumArr + vresult(k)
Next
If oddNo = oddNoReq And evenNo = evenNoReq And sumArr >= minSumValue And sumArr <= maxSumValue Then
lRow = lRow + 1
Range("C" & lRow).Resize(, p) = vresult
Range("I" & lRow) = sumArr
End If
testRow = testRow + 1
Range("k" & testRow).Resize(, p) = vresult
End If
If iIndex <> p Then
Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
End If
sumArr = 0
evenNo = 0
oddNo = 0
Next i
Exit Sub
errHandler:
MsgBox "Error has occured - error no " & Err.Number & " - " & Err.Description
End Sub
Sub headingsInsert()
Application.ScreenUpdating = False
Sheets("Sheet1").Visible = True
Sheets("Sheet1").Range("D1:Q1").Copy
Sheets("Sheet1").Visible = False
Sheets("Combination Generation").Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Sheet1").Visible = False
Columns("I:I").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Application.ScreenUpdating = True
End Sub
Public Function lastRwCt() As Long
Dim o As Long
lastRwCt = Range("A1").CurrentRegion.Count
End Function
Sub sortDataFirst()
Range("A1:A24").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
any question, correction or advise welcome, thanks.
