Generate all patterns between two numbers with constraints using VBA

[Muhammad Hussaan]

Hello,
I need help for a VBA code that generates all possible patterns (without duplication) of numbers with following constraints.
Sum should be less than or equal to 177
Sum should be greater than or equal to 174
Number can be repeated (Example: as in pattern 1 number 60 is two time, 64 is two times in pattern 2)
Numbers should not be greater than 5
All patterns should be unique/non repeating

Currently i am doing this manually and very time taking.
Find screenshot of the excel file, For these 20 number i am able to generate 28 patterns keeping all constraint. Although i have checked but might be i have missed few more possibilities.

For pattern generation i use following sheet by entering and check sum product in column V.

 

[Yongle]

There may be too many values for a worksheet
I will re-write the code so that duplicate rows are eliminated before hitting the worksheet

 

[Yongle]

There may be too many values for a worksheet

That is not the problem
The problem is the amount of time taken to process so many values

I range the range from Set Rng = ActiveSheet.Range("A7:A26") to Set Rng = ActiveSheet.Range("A7:A48")
and the numbers were the following but with the following change it is not working as desired. Kindly help me on this.

Please explain what "is not working as desired"

 

[Muhammad Hussaan]

That is not the problem
The problem is the amount of time taken to process so many values



Please explain what "is not working as desired"

Yes, it take alot of time and after too long generate patterns upto last row that includes repetitive patterns.

 

[Muhammad Hussaan]

That is not the problem
The problem is the amount of time taken to process so many values



Please explain what "is not working as desired"

The output is as follows, just showing last rows but with a lot of repetition.

 

[Yongle]

Status bar (bottom left of screeb) is updated each time loop a is completed to allow user to monitor VBA progress
Place both procedures in the same module
Run from sheet containing the 42 values

Sub TestPattern4()
'declare variables and constants etc
    Dim P(), a As Long, b As Long, c As Long, d As Long, e As Long, r As Long, u As Long
    Dim Str5 As String, Str4 As String, Str3 As String, Stats As String
    Dim sV() As Variant, sv5 As Double, sv4 As Double, sv3 As Double
    Dim ws As Worksheet, coll As New Collection, itm
    Const X = " "
    On Error Resume Next
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Application.StatusBar = "macro running ......"
'base range
    P = ActiveSheet.Range("A7:A48").Value
    u = UBound(P)
'loop all values
        For a = 1 To u                
            For b = 1 To u
                For c = 1 To u
                    For d = 1 To u
                        For e = 1 To u
                            sV = Array(P(a, 1), P(b, 1), P(c, 1), P(d, 1), P(e, 1))
                            Call BubbleSort(sV)
                            sv3 = sV(4) + sV(3) + sV(2)
                            sv4 = sv3 + sV(1)
                            sv5 = sv4 + sV(0)
'add values matching criteria to collection
                            If sv5 >= 174 And sv5 <= 177 Then
                                Str5 = sV(4) & X & sV(3) & X & sV(2) & X & sV(1) & X & sV(0) & X & sv5
                                coll.Add Str5, Str5
                            End If
                            If sv4 >= 174 And sv4 <= 177 Then
                                Str4 = sV(4) & X & sV(3) & X & sV(2) & X & sV(1) & X & X & sv4
                                coll.Add Str4, Str4
                            End If
                            If sv3 >= 174 And sv3 <= 177 Then
                                Str3 = sV(4) & X & sV(3) & X & sV(2) & X & X & X & sv3
                                coll.Add Str3, Str3
                            End If
                        Next e
                    Next d
                Next c
            Next b
                Stats = Left(a & X & Stats, 100)
                Application.StatusBar = Stats
        Next a
'write to worksheet
        If coll.count > 0 Then
            Application.Calculation = xlCalculationManual
            Application.ScreenUpdating = False
            Set ws = Sheets.Add(before:=Sheets(1))
            ws.Cells(1, 1).Resize(, 6) = Array("A", "B", "C", "D", "E", "Sum")
            r = 1
            For Each itm In coll
                r = r + 1
                ws.Cells(r, 1) = itm
            Next itm
        End If
        ws.Range("A2:A" & r).TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1))
        Application.Calculation = xlCalculationAutomatic
        Application.StatusBar = False
End Sub

Private Sub BubbleSort(MyArray() As Variant)
    Dim i As Long, j As Long, Temp As Variant
    For i = LBound(MyArray) To UBound(MyArray) - 1
        For j = i + 1 To UBound(MyArray)
            If MyArray(i) > MyArray(j) Then
                Temp = MyArray(j)
                MyArray(j) = MyArray(i)
                MyArray(i) = Temp
            End If
        Next j
    Next i
End Sub

 

[Muhammad Hussaan]

Status bar (bottom left of screeb) is updated each time loop a is completed to allow user to monitor VBA progress
Place both procedures in the same module
Run from sheet containing the 42 values

Sub TestPattern4()
'declare variables and constants etc
    Dim P(), a As Long, b As Long, c As Long, d As Long, e As Long, r As Long, u As Long
    Dim Str5 As String, Str4 As String, Str3 As String, Stats As String
    Dim sV() As Variant, sv5 As Double, sv4 As Double, sv3 As Double
    Dim ws As Worksheet, coll As New Collection, itm
    Const X = " "
    On Error Resume Next
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Application.StatusBar = "macro running ......"
'base range
    P = ActiveSheet.Range("A7:A48").Value
    u = UBound(P)
'loop all values
        For a = 1 To u                
            For b = 1 To u
                For c = 1 To u
                    For d = 1 To u
                        For e = 1 To u
                            sV = Array(P(a, 1), P(b, 1), P(c, 1), P(d, 1), P(e, 1))
                            Call BubbleSort(sV)
                            sv3 = sV(4) + sV(3) + sV(2)
                            sv4 = sv3 + sV(1)
                            sv5 = sv4 + sV(0)
'add values matching criteria to collection
                            If sv5 >= 174 And sv5 <= 177 Then
                                Str5 = sV(4) & X & sV(3) & X & sV(2) & X & sV(1) & X & sV(0) & X & sv5
                                coll.Add Str5, Str5
                            End If
                            If sv4 >= 174 And sv4 <= 177 Then
                                Str4 = sV(4) & X & sV(3) & X & sV(2) & X & sV(1) & X & X & sv4
                                coll.Add Str4, Str4
                            End If
                            If sv3 >= 174 And sv3 <= 177 Then
                                Str3 = sV(4) & X & sV(3) & X & sV(2) & X & X & X & sv3
                                coll.Add Str3, Str3
                            End If
                        Next e
                    Next d
                Next c
            Next b
                Stats = Left(a & X & Stats, 100)
                Application.StatusBar = Stats
        Next a
'write to worksheet
        If coll.count > 0 Then
            Application.Calculation = xlCalculationManual
            Application.ScreenUpdating = False
            Set ws = Sheets.Add(before:=Sheets(1))
            ws.Cells(1, 1).Resize(, 6) = Array("A", "B", "C", "D", "E", "Sum")
            r = 1
            For Each itm In coll
                r = r + 1
                ws.Cells(r, 1) = itm
            Next itm
        End If
        ws.Range("A2:A" & r).TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1))
        Application.Calculation = xlCalculationAutomatic
        Application.StatusBar = False
End Sub

Private Sub BubbleSort(MyArray() As Variant)
    Dim i As Long, j As Long, Temp As Variant
    For i = LBound(MyArray) To UBound(MyArray) - 1
        For j = i + 1 To UBound(MyArray)
            If MyArray(i) > MyArray(j) Then
                Temp = MyArray(j)
                MyArray(j) = MyArray(i)
                MyArray(i) = Temp
            End If
        Next j
    Next i
End Sub

Thank you very much, working perfectly.

 

[Yongle]

Thanks for your feedback

 

[Muhammad Hussaan]

Thanks for your feedback

Thanks.
Once again i need your help..
As before i was generating patterns from numbers manually therefore they were maximum 100 to 150.
Now with your help i am getting all the pattern possibilities and they are more than 200 in most of the cases depending on the numbers.
after getting the patterns i use excel solver to find the patterns to use to get the number of numbers required. Excel solver has limitation of maximum 200 variables.
It can be done using VBA?
to explain better i change the the input range to A7:A14
On running macro TESTPATTERN it generates output in sheet8 A1:F13
In I2:P13 i use count if.
To get required number of number i use solver. it is working for the less patterns but for over 200 it is not working can we do it with excel vba.

 

[Yongle]

Unable to help, sorry