VBA random numbers generator with required sum

[motilulla]

VBA random numbers generator with required sum </SPAN></SPAN>

I need a VBA that can choose 7 random numbers out of 3 numbers, which are listed in the cells A4:A6 </SPAN></SPAN>

Create for example 50 random in the cells F4:L53 without repetitions (I mean 2 rows should not be the same) as per each row sum is as assigned in the column M, is it possible? (Sum can be vary from 0 to 14)</SPAN></SPAN>

In the example below some set are shown with row sum=7 </SPAN></SPAN>

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3	Total Numbers					n1	n2	n3	n4	n5	n6	n7	SUM
4	0					2	1	0	0	1	1	2	7
5	1					1	1	1	1	2	1	0	7
6	2					0	1	1	2	1	2	0	7
7						1	2	0	0	2	1	1	7
8						1	1	2	0	1	0	2	7
9						2	0	1	1	2	0	1	7
10						0	2	1	1	0	1	2	7
11						0	1	1	1	1	1	2	7
12						1	1	1	2	0	1	1	7
13						0	2	1	1	1	2	0	7
14						1	1	2	2	0	0	1	7
15						1	0	2	0	0	2	2	7
16						1	0	0	1	2	1	2	7
17						1	0	1	2	1	1	1	7
18						2	1	1	1	1	0	1	7
19						1	2	0	1	2	1	0	7
20						1	1	0	2	1	1	1	7
21						1	2	1	2	0	1	0	7
22						0	1	1	1	2	1	1	7
23						0	2	0	1	1	1	2	7
24						1	1	1	2	1	1	0	7
25						0	0	1	1	2	2	1	7
26						1	0	2	1	0	1	2	7
27						1	1	1	1	1	2	0	7
28						1	2	2	0	0	1	1	7
29						1	0	1	1	2	1	1	7
30						0	1	1	2	1	1	1	7
31						1	2	1	1	1	0	1	7
32						0	1	1	2	0	1	2	7
33						1	2	0	2	1	1	0	7
34						1	1	1	1	1	1	1	7
35						2	1	1	1	0	0	2	7
36						2	2	1	0	1	0	1	7
37						1	1	1	0	2	1	1	7
38						0	1	1	1	2	0	2	7
39						0	2	0	2	0	2	1	7
40						1	1	1	2	0	0	2	7
41						1	1	1	1	0	2	1	7
42						2	0	2	1	1	1	0	7
43						1	0	2	2	1	1	0	7
44						2	1	0	2	0	1	1	7
45						1	1	2	1	0	2	0	7
46						2	2	1	0	0	1	1	7
47						1	1	2	1	0	1	1	7
48						1	0	2	1	1	0	2	7
49						1	1	2	1	1	1	0	7
50						2	1	2	0	1	0	1	7
51						2	2	1	0	0	0	2	7
52						1	2	1	1	0	2	0	7
53						1	1	1	0	1	2	1	7
Sheet1

Thank you all</SPAN></SPAN>

Excel 2000</SPAN></SPAN>
Regards,</SPAN></SPAN>
Moti</SPAN></SPAN>

 

[motilulla]

Bump

 

[rlv01]

Sub DoSomething()
    Dim WS As Worksheet
    Dim RangeOfCells As Range, RR As Range, RC As Range
    Dim I As Long
    Dim S As String
    Dim SD As Object
    Dim DoNextRow As Boolean

    Set WS = ActiveSheet
    Set SD = CreateObject("Scripting.dictionary")
    Set RangeOfCells = WS.Range("F4:L53")             'Your example range

    For Each RR In Intersect(RangeOfCells.Columns(1), RangeOfCells)
        I = 0
        S = ""
        Do
            For Each RC In Intersect(RR.EntireRow, RangeOfCells)
                RC.Value = Application.WorksheetFunction.RandBetween(0, 2)
                S = S & RC.Value
            Next RC

            DoNextRow = Not SD.exists(S)
            If DoNextRow Then
                SD.Add S, 0                           'Unique row
            End If
            I = I + 1
            S = ""
        Loop Until DoNextRow Or I > 10000             'I > 10000 is to prevent a runaway loop.
    Next RR
    Set SD = Nothing
End Sub

 

[motilulla]

Sub DoSomething()
   
 End Sub

Thank you rlv01, code stop at the line below and produce the error "438". </SPAN></SPAN>Please could you check it? </SPAN></SPAN>

RC.Value = Application.WorksheetFunction.RandBetween(0, 2)</SPAN></SPAN>

Regards,</SPAN></SPAN>
Moti</SPAN></SPAN>

 

[Akuini]

Thank you rlv01, code stop at the line below and produce the error "438". Please could you check it?

RC.Value = Application.WorksheetFunction.RandBetween(0, 2)

Regards,
Moti

Maybe EXCEL 2000 doesn't have RandBetween function?

 

[rlv01]

Also you may need to be sure the Analysis ToolPak is loaded.

 

[motilulla]

Maybe EXCEL 2000 doesn't have RandBetween function?

@ Hello Akuini, it is true thank you for the observations

Also you may need to be sure the Analysis ToolPak is loaded.

@ Hello rlv01, after Akuini message, goggling I found some suggestions under this link---> http://www.cpearson.com/excel/ATP.htm

After making the settings as shown, code did not worked, but some ware in the MrExcel I read that in the excel 2000 random RandBetween can be used without but the "Application.WorksheetFunction" following the steps I modified the code line, as shown below</SPAN></SPAN>

</SPAN></SPAN>
This...</SPAN></SPAN>

RC.Value = Application.WorksheetFunction.RandBetween(0, 2)</SPAN></SPAN>



To this...</SPAN></SPAN>

RC.Value = RandBetween(0, 2)</SPAN></SPAN>

</SPAN></SPAN>

Macro worked but it generate each line with different sum from 1 to 14 how can I get all lines with sum as per choice in the column M as shown #post 1 all lines with sum 7 only
</SPAN></SPAN>

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3	Total Numbers					n1	n2	n3	n4	n5	n6	n7	SUM
4	0					1	1	2	1	2	1	2	10
5	1					0	2	1	1	0	1	2	7
6	2					1	0	2	1	0	1	1	6
7						1	0	1	1	1	1	2	7
8						1	0	1	1	2	1	1	7
9						2	0	1	1	0	2	2	8
10						1	0	1	2	2	0	2	8
11						1	0	1	1	1	1	1	6
12						0	1	1	2	2	0	2	8
13						2	0	1	0	2	0	1	6
14						1	0	0	1	1	2	0	5
15						2	1	2	2	0	2	2	11
16						0	1	1	1	1	1	1	6
17						2	2	2	2	2	2	1	13
18						0	2	0	2	1	1	0	6
19						1	0	1	0	2	1	1	6
20						0	1	1	0	2	1	0	5
21						2	1	0	0	0	0	2	5
22						1	1	2	2	2	0	0	8
23						0	2	2	1	0	2	1	8
24						1	0	0	0	2	2	0	5
25						2	0	1	1	1	0	2	7
26						0	2	2	0	2	2	1	9
27						1	0	0	0	0	0	0	1
28						2	1	2	1	1	2	0	9
29						1	1	0	1	1	2	1	7
30						0	1	2	1	2	2	2	10
31						1	2	0	2	1	0	2	8
32						2	0	1	0	1	1	2	7
33						0	0	2	2	2	2	1	9
34						1	2	0	0	0	0	2	5
35						2	0	1	1	1	1	2	8
36						0	2	0	1	0	0	0	3
37						2	2	0	2	0	1	0	7
38						2	2	1	0	1	1	1	8
39						0	0	2	1	2	0	0	5
40						1	1	0	2	1	0	2	7
41						1	1	1	0	2	2	1	8
42						2	1	0	0	0	0	1	4
43						1	0	2	0	2	0	2	7
44						0	2	1	0	0	1	1	5
45						1	1	2	2	2	0	1	9
46						2	0	2	0	0	1	1	6
47						2	2	2	2	2	1	0	11
48						0	1	2	2	1	1	2	9
49						2	1	2	1	2	0	1	9
50						2	0	1	1	1	2	2	9
51						1	1	0	1	0	0	1	4
52						2	2	1	1	0	1	1	8
53						1	2	2	1	1	1	2	10
Sheet1

Regards,</SPAN>
Moti</SPAN></SPAN></SPAN>

 

[Phuoc]

Try:

Sub DoSomething()
    Dim WS As Worksheet
    Dim RangeOfCells As Range, RR As Range, RC As Range
    Dim I As Long
    Dim S As String
    Dim SD As Object
    Dim DoNextRow As Boolean


    Set WS = ActiveSheet
    Set SD = CreateObject("Scripting.dictionary")
    Set RangeOfCells = WS.Range("F4:L53")             'Your example range
Randomize
    For Each RR In Intersect(RangeOfCells.Columns(1), RangeOfCells)
        I = 0
        S = ""
        Do
            For Each RC In Intersect(RR.EntireRow, RangeOfCells)
                RC.Value = Int(Rnd() * 3)
                S = S & RC.Value
            Next RC


            DoNextRow = Not SD.exists(S)
            If DoNextRow Then
                SD.Add S, 0                           'Unique row
            End If
            I = I + 1
            S = ""
        Loop Until DoNextRow Or I > 10000             'I > 10000 is to prevent a runaway loop.
    Next RR
    Set SD = Nothing
End Sub

 

[Phuoc]

Or try:

Public Sub MyRandom()
Dim arr(1 To 7)
Dim i As Long
Dim mySum As Long
Randomize
Do While mySum <> 7
mySum = 0
    For i = 1 To 7
        arr(i) = Int(Rnd() * 3)
        mySum = mySum + arr(i)
    Next
Loop
Range("A1:G1") = arr


End Sub

 

[motilulla]

Try:

Sub DoSomething()
    Dim WS As Worksheet
    Dim RangeOfCells As Range, RR As Range, RC As Range
    Dim I As Long
    Dim S As String
    Dim SD As Object
    Dim DoNextRow As Boolean


    Set WS = ActiveSheet
    Set SD = CreateObject("Scripting.dictionary")
    Set RangeOfCells = WS.Range("F4:L53")             'Your example range
Randomize
    For Each RR In Intersect(RangeOfCells.Columns(1), RangeOfCells)
        I = 0
        S = ""
        Do
            For Each RC In Intersect(RR.EntireRow, RangeOfCells)
               RC.Value = Int(Rnd() * 3)
                S = S & RC.Value
            Next RC


            DoNextRow = Not SD.exists(S)
            If DoNextRow Then
                SD.Add S, 0                           'Unique row
            End If
            I = I + 1
            S = ""
        Loop Until DoNextRow Or I > 10000             'I > 10000 is to prevent a runaway loop.
    Next RR
    Set SD = Nothing
End Sub

Thank you Phuoc, for your help, but code is also doing the same generating all rows with different sums I want with the sum as per column M as shown in the post#1</SPAN></SPAN>

Regards,</SPAN></SPAN>
Moti </SPAN></SPAN>