Generate all patterns between two numbers with constraints using VBA

M

Muhammad Hussaan

New Member
Joined
Dec 13, 2017
Messages
49
Office Version
  1. 2013
Platform
  1. Windows
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.

Patterns.jpg


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

Pattern 2.jpg
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Try this
- values in A7:A26 as per your data

VBA Code: 
Sub TestPattern()
    Dim P(), a As Long, b As Long, c As Long, d As Long, e As Long, r As Long, u As Long, count As Long
    Dim aV As Double, bV As Double, cV As Double, dV As Double, eV As Double, sV As Double
    Dim ws As Worksheet
   
    P = ActiveSheet.Range("A7:A26").Value
   
    On Error Resume Next
    Set ws = Sheets.Add(before:=Sheets(1))
   
    u = UBound(P)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ws.Cells(1, 1).Resize(, 6) = Array("A", "B", "C", "D", "E", "Sum")
    r = 1
'fives
        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
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                            dV = P(d, 1)
                            eV = P(e, 1)
                            sV = aV + bV + cV + dV + eV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, dV, eV, sV)
                            End If
                        Next e
                    Next d
                Next c
            Next b
        Next a
'fours
        For a = 1 To u
            For b = 1 To u
                For c = 1 To u
                    For d = 1 To u
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                            dV = P(d, 1)
                           
                            sV = aV + bV + cV + dV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, dV, , sV)
                            End If
                    Next d
                Next c
            Next b
        Next a
'threes
        For a = 1 To u
            For b = 1 To u
                For c = 1 To u
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                           
                            sV = aV + bV + cV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, , , sV)
                            End If
                Next c
            Next b
        Next a
    Application.Calculation = xlCalculationManual
End Sub
 
Upvote 0
Yongle said:
Try this
- values in A7:A26 as per your data

VBA Code: 
Sub TestPattern()
    Dim P(), a As Long, b As Long, c As Long, d As Long, e As Long, r As Long, u As Long, count As Long
    Dim aV As Double, bV As Double, cV As Double, dV As Double, eV As Double, sV As Double
    Dim ws As Worksheet
  
    P = ActiveSheet.Range("A7:A26").Value
  
    On Error Resume Next
    Set ws = Sheets.Add(before:=Sheets(1))
  
    u = UBound(P)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ws.Cells(1, 1).Resize(, 6) = Array("A", "B", "C", "D", "E", "Sum")
    r = 1
'fives
        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
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                            dV = P(d, 1)
                            eV = P(e, 1)
                            sV = aV + bV + cV + dV + eV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, dV, eV, sV)
                            End If
                        Next e
                    Next d
                Next c
            Next b
        Next a
'fours
        For a = 1 To u
            For b = 1 To u
                For c = 1 To u
                    For d = 1 To u
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                            dV = P(d, 1)
                          
                            sV = aV + bV + cV + dV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, dV, , sV)
                            End If
                    Next d
                Next c
            Next b
        Next a
'threes
        For a = 1 To u
            For b = 1 To u
                For c = 1 To u
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                          
                            sV = aV + bV + cV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, , , sV)
                            End If
                Next c
            Next b
        Next a
    Application.Calculation = xlCalculationManual
End Sub
Click to expand...
Thank you very much. it is working perfectly.
Need your help to change one thing; to avoid repetition of patterns. find attached screen shoot.
The column A to F generated from VBA run. from column I to AB i have inserted the numbers for which the patterns are required and use count function from row 2 onward.
The pattern starts from row 2.
The pattern in row 2 is repeating in row 7, row 20 (only sequence is different)
similarly row 3, row 6, row 8, row 12, row 18, row 19, row 21, row 25 are same only sequence is different.

Pattern vba.jpg
 
Upvote 0
try this

VBA Code: 
Sub TestPattern2()
    Dim P(), a As Long, b As Long, c As Long, D As Long, e As Long, r As Long, u As Long, count As Long
    Dim aV As Double, bV As Double, cV As Double, dV As Double, eV As Double, sV As Double
    Dim ws As Worksheet, Rng As Range
    
    Set Rng = ActiveSheet.Range("A7:A26")
    Rng.Sort Key1:=Rng.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
    P = Rng.Value
    On Error Resume Next
    Set ws = Sheets.Add(before:=Sheets(1))
    
    u = UBound(P)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ws.Cells(1, 1).Resize(, 6) = Array("A", "B", "C", "D", "E", "Sum")
    r = 1
'fives
        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
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                            dV = P(D, 1)
                            eV = P(e, 1)
                            'fives
                            sV = aV + bV + cV + dV + eV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, dV, eV, sV)
                            End If
                            'fours
                            sV = aV + bV + cV + dV
                            If sV >= 174 And sV <= 177 Then
                            r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, dV, , sV)
                            End If
                            'threes
                            sV = aV + bV + cV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 6) = Array(aV, bV, cV, , , sV)
                            End If
                        Next e
                    Next D
                Next c
            Next b
        Next a
       
        ws.Range("A:F").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes
        Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
Ignore post#4 - it does not remove all duplicates
 
Upvote 0
Perhaps ..

VBA Code: 
    Dim P(), a As Long, b As Long, c As Long, d As Long, e As Long, r As Long, u As Long, count As Long
    Dim aV As Double, bV As Double, cV As Double, dV As Double, eV As Double, sV As Double
    Dim ws As Worksheet, Rng As Range
  
    Set Rng = ActiveSheet.Range("A7:A26")

    P = Rng.Value
    On Error Resume Next
    Set ws = Sheets.Add(before:=Sheets(1))
  
    u = UBound(P)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ws.Cells(1, 1).Resize(, 6) = Array("A", "B", "C", "D", "E", "Sum")
    r = 1
'fives
        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
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                            dV = P(D, 1)
                            eV = P(e, 1)
                            'fives
                            sV = aV + bV + cV + dV + eV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 5) = Split(SortValues(Array(aV, bV, cV, dV, eV)))
                                ws.Cells(r, 6) = sV
                            End If
                            'fours
                            sV = aV + bV + cV + dV
                            If sV >= 174 And sV <= 177 Then
                            r = r + 1
                                ws.Cells(r, 1).Resize(, 4) = Split(SortValues(Array(aV, bV, cV, dV)))
                                ws.Cells(r, 6) = sV
                            End If
                            'threes
                            sV = aV + bV + cV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 3) = Split(SortValues(Array(aV, bV, cV)))
                                ws.Cells(r, 6) = sV
                            End If
                        Next e
                    Next d
                Next c
            Next b
        Next a
     
        ws.Range("A1:F" & r).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes
        ws.Range("A1").CurrentRegion.Value = ws.Range("A1").CurrentRegion.Value
        Application.Calculation = xlCalculationAutomatic
End Sub

Private Function SortValues(ByRef x As Variant) As Variant
    Dim a As Long, s As String
    With WorksheetFunction
        For a = 0 To UBound(x)
            s = s & " " & .Large(x, a + 1)
        Next a
    End With
    s = Trim(s)
    SortValues = s
End Function
 
Upvote 0
Yongle said:
Perhaps ..

VBA Code: 
    Dim P(), a As Long, b As Long, c As Long, d As Long, e As Long, r As Long, u As Long, count As Long
    Dim aV As Double, bV As Double, cV As Double, dV As Double, eV As Double, sV As Double
    Dim ws As Worksheet, Rng As Range
  
    Set Rng = ActiveSheet.Range("A7:A26")

    P = Rng.Value
    On Error Resume Next
    Set ws = Sheets.Add(before:=Sheets(1))
  
    u = UBound(P)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ws.Cells(1, 1).Resize(, 6) = Array("A", "B", "C", "D", "E", "Sum")
    r = 1
'fives
        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
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                            dV = P(D, 1)
                            eV = P(e, 1)
                            'fives
                            sV = aV + bV + cV + dV + eV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 5) = Split(SortValues(Array(aV, bV, cV, dV, eV)))
                                ws.Cells(r, 6) = sV
                            End If
                            'fours
                            sV = aV + bV + cV + dV
                            If sV >= 174 And sV <= 177 Then
                            r = r + 1
                                ws.Cells(r, 1).Resize(, 4) = Split(SortValues(Array(aV, bV, cV, dV)))
                                ws.Cells(r, 6) = sV
                            End If
                            'threes
                            sV = aV + bV + cV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 3) = Split(SortValues(Array(aV, bV, cV)))
                                ws.Cells(r, 6) = sV
                            End If
                        Next e
                    Next d
                Next c
            Next b
        Next a
     
        ws.Range("A1:F" & r).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes
        ws.Range("A1").CurrentRegion.Value = ws.Range("A1").CurrentRegion.Value
        Application.Calculation = xlCalculationAutomatic
End Sub

Private Function SortValues(ByRef x As Variant) As Variant
    Dim a As Long, s As String
    With WorksheetFunction
        For a = 0 To UBound(x)
            s = s & " " & .Large(x, a + 1)
        Next a
    End With
    s = Trim(s)
    SortValues = s
End Function
Click to expand...
Working perfectly.
Thank you very much for helping.
 
Upvote 0
Yongle said:
Perhaps ..

VBA Code: 
    Dim P(), a As Long, b As Long, c As Long, d As Long, e As Long, r As Long, u As Long, count As Long
    Dim aV As Double, bV As Double, cV As Double, dV As Double, eV As Double, sV As Double
    Dim ws As Worksheet, Rng As Range
 
    Set Rng = ActiveSheet.Range("A7:A26")

    P = Rng.Value
    On Error Resume Next
    Set ws = Sheets.Add(before:=Sheets(1))
 
    u = UBound(P)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ws.Cells(1, 1).Resize(, 6) = Array("A", "B", "C", "D", "E", "Sum")
    r = 1
'fives
        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
                            aV = P(a, 1)
                            bV = P(b, 1)
                            cV = P(c, 1)
                            dV = P(D, 1)
                            eV = P(e, 1)
                            'fives
                            sV = aV + bV + cV + dV + eV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 5) = Split(SortValues(Array(aV, bV, cV, dV, eV)))
                                ws.Cells(r, 6) = sV
                            End If
                            'fours
                            sV = aV + bV + cV + dV
                            If sV >= 174 And sV <= 177 Then
                            r = r + 1
                                ws.Cells(r, 1).Resize(, 4) = Split(SortValues(Array(aV, bV, cV, dV)))
                                ws.Cells(r, 6) = sV
                            End If
                            'threes
                            sV = aV + bV + cV
                            If sV >= 174 And sV <= 177 Then
                                r = r + 1
                                ws.Cells(r, 1).Resize(, 3) = Split(SortValues(Array(aV, bV, cV)))
                                ws.Cells(r, 6) = sV
                            End If
                        Next e
                    Next d
                Next c
            Next b
        Next a
    
        ws.Range("A1:F" & r).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes
        ws.Range("A1").CurrentRegion.Value = ws.Range("A1").CurrentRegion.Value
        Application.Calculation = xlCalculationAutomatic
End Sub

Private Function SortValues(ByRef x As Variant) As Variant
    Dim a As Long, s As String
    With WorksheetFunction
        For a = 0 To UBound(x)
            s = s & " " & .Large(x, a + 1)
        Next a
    End With
    s = Trim(s)
    SortValues = s
End Function
Click to expand...
Hello,
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.
24​
25​
26​
27​
28​
29​
30​
32​
34​
38​
40.55​
45​
46​
48​
55​
56​
58​
58.5​
59​
60​
61​
62​
64​
65​
66​
67​
68​
69​
70​
71​
75​
76​
77​
82​
86​
87​
89​
90​
91​
92​
96​
98​
 
Upvote 0
There are now over 160 million combinations

How many numbers are you intending to use ?
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Formula to find the in-between number in a range
Replies
2
Views
202
Fluff
Fluff
M
  • Question
Count number of Occurrences of Name in list
Replies
5
Views
130
alansidman
A
R
  • Solved
Sequencing Numbers Not Working
Replies
4
Views
393
DanteAmor
DanteAmor
U
  • Question
VBA, Formula, or Data Validation Excel form
Replies
1
Views
367
NateSC
NateSC
A
  • Question
Web Scraping using vba
2
Replies
15
Views
4K
Abdmujib
A

Forum statistics

Threads
1,215,409
Messages
6,124,743
Members
449,186
Latest member
HBryant

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top