Number Shuffle - Greater than last number, No repeats.

JBowman · Feb 17, 2021

Hi All,
I am using Excel 2019 & have a requirement to shuffle a fixed set of numbers in column B so that they are greater than the numbers in column A.
The numbers in column B must only be all those numbers, (so a RAND function wont work) and must be all inclusive between 10 & 29 without duplication or a number missing.
Additionally the distance between the numbers in column A & B cant be greater than 20, i.e. the number in A1 is "1" and so the number in B1 cant be greater than "21", it must be between 2 & 20 etc..

I have played around with this without much success for a long time & now i need some help!!

Number Shuffle.xlsx

A

B

C

D

E

F

G

H

I

J

K

L

M

N

1

10

2

11

3

12

4

13

5

14

6

15

7

16

8

17

9

18

10

19

11

20

12

21

13

22

14

23

15

24

16

25

17

26

18

27

19

28

20

29

21

22

23

24

25

26

27

Sheet1

RickXL · Feb 25, 2021

Would a VBA solution be acceptable?

I put the results in column C.
Columns D to W are just so I can easily check for duplicates and are not part of the solution.
Basically, you click on the (optional) button and you get a new set of numbers.

JBowman · Mar 1, 2021

Hi, this looks like it could work, how can i download your solution to try it out?

JBowman · Mar 1, 2021

RickXL said:
Would a VBA solution be acceptable?

I put the results in column C.
Columns D to W are just so I can easily check for duplicates and are not part of the solution.
Basically, you click on the (optional) button and you get a new set of numbers.

View attachment 33053

Hi, this looks like it could work, how can i download your solution to try it out?

RickXL · Mar 1, 2021

Hi,

You will need to create a new Module and paste in the code below.
You may need to go into Tools->References to include mscorlib.dll but it worked for me without having to do that.
There is an issue in that that the numbers for rows 1 to 9 can be chosen without using the number 10 (or 1-10 without 11 etc) but 10 cannot be used elsewhere. If an invalid set of numbers is found the code loops until a valid set is discovered. It usually only takes one iteration but it has taken 8 on a couple of occasions.

The numbers are chosen for the top and bottom rows first and then it works towards the middle.

VBA Code:

' Sorted list Info: http://www.snb-vba.eu/VBA_Sortedlist_en.html
' Tools-->references to mscorlib.dll may be required

' Program makes a master list of all numbers
' Then it subsets the low numbers if the number exists in the master list and finds a random number
' next it removes the number just found from the master list and repeats the process for high numbers
' In case a working number set is not found the Do Until repeats as necessary

Option Explicit

Sub GetNumbers()

    Dim slMast  As Object
    Dim slTemp  As Object
    Dim i       As Long
    Dim j       As Long
    Dim Ans     As Long
    Dim loMin   As Long
    Dim loMax   As Long
    Dim hiMin   As Long
    Dim noError As Boolean
    Dim ws      As Worksheet
    
    Set ws = Worksheets("Sheet1")
    ws.Range("C1:C20").ClearContents
    
    Set slMast = CreateObject("System.Collections.SortedList")
    Set slTemp = CreateObject("System.Collections.SortedList")
    
    
    Do Until noError
        ' Populate Master List
        slMast.Clear
        For i = 10 To 29
            slMast.Add Format(i, "00"), i
        Next
        
        noError = True
        For j = 1 To 10
        
            ' Fill Temp List from Master with HIGH Numbers
            hiMin = WorksheetFunction.Max(10, 22 - j)
            slTemp.Clear
            For i = hiMin To 29
                If slMast.Item(Format(i, "00")) > 0 Then
                    slTemp.Add Format(Rnd(), "0.0000000") & Format(i, "00"), i
                End If
            Next i
        
            ' Number found - output and remove
            If slTemp.Count > 0 Then
                Ans = slTemp.Getbyindex(0)
            Else
                noError = False
            End If

            ws.Cells(hiMin - 1, 3) = Ans
            slMast.Remove Format(Ans, "00")
            
            ' Fill Temp List from Master with LOW Numbers
            loMin = WorksheetFunction.Max(10, j + 1)
            loMax = WorksheetFunction.Min(j + 20, 29)
            slTemp.Clear
            For i = loMin To loMax
                If slMast.Item(Format(i, "00")) > 0 Then
                    slTemp.Add Format(Rnd(), "0.0000000") & Format(i, "00"), i
                End If
            Next i
        
            ' Number found - output and remove
            If slTemp.Count > 0 Then
                Ans = slTemp.Getbyindex(0)
            Else
                noError = False
            End If
            ws.Cells(j, 3) = Ans
            slMast.Remove Format(Ans, "00")
  
        Next j

    Loop

End Sub

Phuoc · Mar 1, 2021

Try this

Book1

A

B

C

D

E

F

G

H

I

J

K

L

M

1

10

11

2

11

17

3

12

10

4

13

23

5

14

16

6

15

18

7

16

14

8

17

22

9

18

13

10

19

24

11

20

12

21

29

13

22

19

14

23

15

24

27

16

25

21

17

26

25

18

27

26

19

28

20

29

28

Sheet1

Cell Formulas
Range	Formula
C1	C1	=RANDBETWEEN(10,29)
C2:C20	C2	=IF(AGGREGATE(15,6,$B$1:$B$20/(COUNTIF($C$1:C1,$B$1:$B$20)=0),1)=A2+1,A2+1,AGGREGATE(15,6,$B$1:$B$20/(COUNTIF($C$1:C1,$B$1:$B$20)=0)/($B$1:$B$20>A2)/($B$1:$B$20<A2+20),RANDBETWEEN(1,COUNT($B$1:$B$20/(COUNTIF($C$1:C1,$B$1:$B$20)=0)/($B$1:$B$20>A2)/($B$1:$B$20<A2+20)))))
Press CTRL+SHIFT+ENTER to enter array formulas.

JBowman · Mar 5, 2021

RickXL said:

Hi,

You will need to create a new Module and paste in the code below.
You may need to go into Tools->References to include mscorlib.dll but it worked for me without having to do that.
There is an issue in that that the numbers for rows 1 to 9 can be chosen without using the number 10 (or 1-10 without 11 etc) but 10 cannot be used elsewhere. If an invalid set of numbers is found the code loops until a valid set is discovered. It usually only takes one iteration but it has taken 8 on a couple of occasions.

The numbers are chosen for the top and bottom rows first and then it works towards the middle.

VBA Code:

' Sorted list Info: http://www.snb-vba.eu/VBA_Sortedlist_en.html
' Tools-->references to mscorlib.dll may be required

' Program makes a master list of all numbers
' Then it subsets the low numbers if the number exists in the master list and finds a random number
' next it removes the number just found from the master list and repeats the process for high numbers
' In case a working number set is not found the Do Until repeats as necessary

Option Explicit

Sub GetNumbers()

    Dim slMast  As Object
    Dim slTemp  As Object
    Dim i       As Long
    Dim j       As Long
    Dim Ans     As Long
    Dim loMin   As Long
    Dim loMax   As Long
    Dim hiMin   As Long
    Dim noError As Boolean
    Dim ws      As Worksheet
   
    Set ws = Worksheets("Sheet1")
    ws.Range("C1:C20").ClearContents
   
    Set slMast = CreateObject("System.Collections.SortedList")
    Set slTemp = CreateObject("System.Collections.SortedList")
   
   
    Do Until noError
        ' Populate Master List
        slMast.Clear
        For i = 10 To 29
            slMast.Add Format(i, "00"), i
        Next
       
        noError = True
        For j = 1 To 10
       
            ' Fill Temp List from Master with HIGH Numbers
            hiMin = WorksheetFunction.Max(10, 22 - j)
            slTemp.Clear
            For i = hiMin To 29
                If slMast.Item(Format(i, "00")) > 0 Then
                    slTemp.Add Format(Rnd(), "0.0000000") & Format(i, "00"), i
                End If
            Next i
       
            ' Number found - output and remove
            If slTemp.Count > 0 Then
                Ans = slTemp.Getbyindex(0)
            Else
                noError = False
            End If

            ws.Cells(hiMin - 1, 3) = Ans
            slMast.Remove Format(Ans, "00")
           
            ' Fill Temp List from Master with LOW Numbers
            loMin = WorksheetFunction.Max(10, j + 1)
            loMax = WorksheetFunction.Min(j + 20, 29)
            slTemp.Clear
            For i = loMin To loMax
                If slMast.Item(Format(i, "00")) > 0 Then
                    slTemp.Add Format(Rnd(), "0.0000000") & Format(i, "00"), i
                End If
            Next i
       
            ' Number found - output and remove
            If slTemp.Count > 0 Then
                Ans = slTemp.Getbyindex(0)
            Else
                noError = False
            End If
            ws.Cells(j, 3) = Ans
            slMast.Remove Format(Ans, "00")
 
        Next j

    Loop

End Sub

Thank you for this, it works great but i dont understand VBA enough to amend this as the numbers & criteria change.

JBowman · Mar 5, 2021

Phuoc said:
Try this

Book1
A B C D E F G H I J K L M
1 1 10 11
2 2 11 17
3 3 12 10
4 4 13 23
5 5 14 16
6 6 15 18
7 7 16 14
8 8 17 22
9 9 18 13
10 10 19 24
11 11 20 12
12 12 21 29
13 13 22 19
14 14 23 15
15 15 24 27
16 16 25 21
17 17 26 25
18 18 27 26
19 19 28 20
20 20 29 28
Sheet1
Cell Formulas
Range Formula
C1 C1 =RANDBETWEEN(10,29)
C2:C20 C2 =IF(AGGREGATE(15,6,$B$1:$B$20/(COUNTIF($C$1:C1,$B$1:$B$20)=0),1)=A2+1,A2+1,AGGREGATE(15,6,$B$1:$B$20/(COUNTIF($C$1:C1,$B$1:$B$20)=0)/($B$1:$B$20>A2)/($B$1:$B$20<A2+20),RANDBETWEEN(1,COUNT($B$1:$B$20/(COUNTIF($C$1:C1,$B$1:$B$20)=0)/($B$1:$B$20>A2)/($B$1:$B$20<A2+20)))))
Press CTRL+SHIFT+ENTER to enter array formulas.

Hi, this solution is perfect & i really appreciate the time taken to do this, as i have managed to help resolve this problem, however.... i was wondering if this can be adjusted for the following dilemma.
While appreciate this wasn't part of the initial request, when i have changed the input numbers, i get the #NUM error, i understand that this is because it wont duplicate numbers & runs out of an answer at 15, can the formula be amended to suit the multiple numbers?

Number Shuffle Solution.xlsm

A

B

C

D

E

F

G

H

1

3

19

2

1

4

15

3

2

5

3

4

2

5

2

6

10

6

2

7

16

7

2

8

14

8

2

9

29

9

3

9

4

10

4

10

20

11

4

10

9

12

4

10

6

13

4

10

21

14

5

10

13

15

5

12

24

16

5

12

23

17

5

12

18

6

12

7

19

6

13

27

20

6

13

33

21

6

14

32

22

7

14

8

23

7

15

25

24

7

15

22

25

7

15

18

26

8

15

28

27

9

16

#NUM!

28

9

18

#NUM!

29

10

19

#NUM!

30

10

19

#NUM!

31

11

20

#NUM!

32

12

20

#NUM!

33

12

20

#NUM!

34

13

20

#NUM!

35

14

21

#NUM!

36

14

21

#NUM!

37

15

22

#NUM!

38

16

23

#NUM!

39

16

23

#NUM!

40

16

24

#NUM!

41

16

25

#NUM!

42

16

27

#NUM!

43

18

28

#NUM!

44

19

29

#NUM!

45

21

32

#NUM!

46

25

33

#NUM!

47

25

33

#NUM!

48

Sheet2 (2)

Cell Formulas
Range	Formula
C1	C1	=RANDBETWEEN(10,20)
C2:C47	C2	=IF(AGGREGATE(15,6,$B$1:$B$47/(COUNTIF($C$1:C1,$B$1:$B$47)=0),1)=A2+1,A2+1,AGGREGATE(15,6,$B$1:$B$47/(COUNTIF($C$1:C1,$B$1:$B$47)=0)/($B$1:$B$47>A2)/($B$1:$B$47<A2+$I$1),RANDBETWEEN(1,COUNT($B$1:$B$47/(COUNTIF($C$1:C1,$B$1:$B$47)=0)/($B$1:$B$47>A2)/($B$1:$B$47<A2+$I$1)))))
Press CTRL+SHIFT+ENTER to enter array formulas.

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C1:C47	Cell Value	duplicates	text	NO
C1:C47	Cell Value	duplicates	text	NO

Phuoc · Mar 5, 2021

Number 5 has 2 times in column B, do you want it to be 2 times in the result column?

JBowman · Mar 5, 2021

Phuoc said:
Number 5 has 2 times in column B, do you want it to be 2 times in the result column?

Hi, yes there are duplicates in each column, essentially these are the Euro lottery numbers drawn over a 47 week period i.e. the first & second numbers on a lottery ticket sorted low to high, so yes i need all the duplicate numbers i.e. 5 two times, 10 five times etc..

Number Shuffle - Greater than last number, No repeats.

JBowman

New Member

Excel Facts

RickXL

MrExcel MVP

Attachments

JBowman

New Member

JBowman

New Member

RickXL

MrExcel MVP

Phuoc

Well-known Member

JBowman

New Member

JBowman

New Member

Phuoc

Well-known Member

JBowman

New Member

Similar threads

Forum statistics

Share this page

Number Shuffle - Greater than last number, No repeats.

New Member

Excel Facts

MrExcel MVP

Attachments

New Member

New Member

MrExcel MVP

Well-known Member

New Member

New Member

Well-known Member

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock