Would like to auto refresh (F9) or recalculate until a cell's value is zero

[vannirae]

I have a workbook that randomly selects a number out four sets of numbers; 1-6, 7-12, 13-18 & 19-24. The result is 1 number out of each group; such as.. 1,12,15,22 Each number is assigned a unique number. The unique numbers are summed and the cell containing the sum highlights if there is a duplicate set of numbers. The cells that are duplicates are counted with countif function. I'm looking for a way to auto refresh or auto recalculate until the cell that counts the duplicates is zero and then stop calculating. Is there a way to do this?

 

[BSALV]

with formulas like that in a worksheet, no, imossible.
You need VBA, to remember previous calculations.

 

[vannirae]

with formulas like that in a worksheet, no, imossible.
You need VBA, to remember previous calculations.

Could you’ll help me with a VBA code to recalculate all sheets until cell A1 is equal to zero and once A1 is equal to zero recalculation stops?

 

[BSALV]

first i have to understand the question.
The 4 randbetweens, no problem, but then ....

Map1
	A	B	C	D	E
1	4	8	13	24
2
3
4
Blad1

Cell Formulas
Range	Formula
A1	A1	=RANDBETWEEN(1,6)
B1	B1	=RANDBETWEEN(7,12)
C1	C1	=RANDBETWEEN(13,18)
D1	D1	=RANDBETWEEN(19,24)

 

[vannirae]

first i have to understand the question.
The 4 randbetweens, no problem, but then ....

Map1
	A	B	C	D	E
1	4	8	13	24
2
3
4
Blad1

Cell Formulas
Range	Formula
A1	A1	=RANDBETWEEN(1,6)
B1	B1	=RANDBETWEEN(7,12)
C1	C1	=RANDBETWEEN(13,18)
D1	D1	=RANDBETWEEN(19,24)

Ok let me see if I can explain this so it makes sense with some screen shots

1. Here is the rand(), that was easy.

2. Then each random number is assigned a unique number.

3. Then the random number is assigned a name.

4. The sum of the unique numbers is calculated. If more than 1 have the same sum, then it is a duplicate combination.

5. My sheet has calculates a total of 250 combinations. This is the only way I was able to figure out how to determine how many unique sums there were. I'm sure there is a better way.

6. Again, this is the best way I could figure to get to the number of duplicates. In the next 3 images, I add 250 to value in A9, subtract 10 in C9 (not sure why this is, but is only way I could get number of duplicate cells, then divided C9 value by 2. For some reason it works, D9 is how many name combinations have a duplicate.

7. I also have conditional formatting so if it is a duplicate, it is highlighted as shown below.

I currently press F9 to re-randomize or recalculate and the number of duplicates changes constantly. My goal is to have no duplicates. There is a possible 1296 combinations, so getting 250 unique is definitely possible. I get in the F9 pressing mode and a 0 duplicates comes up every so often, but since I am in the fast key pressing mode, I press again and lose it. I would like to have a code and assign it to an icon to click and it will recalculate until C9 is zero. Hope this helps explain better. Let me know if you need more info.

 

[BSALV]

you have 4 groups of 6 persons and each time you take 1 person of each group to make a new sample.
you want to do this 4 times and an already choosen person may not be selected a 2nd time.
Correct ?
2010 is your actual excel-version ?

 

[vannirae]

you have 4 groups of 6 persons and each time you take 1 person of each group to make a new sample.
you want to do this 4 times and an already choosen person may not be selected a 2nd time.
Correct ?
2010 is your actual excel-version ?

So yes. Each sample will have 1 of the 6 from each group of 4. Extracting 250 samples, so just do not want duplicate samples.

 

[BSALV]

you want 1 draw or you want 250 ?

Sub Draw_4by4()
     Dim Result(1 To 4, 1 To 4), Rand, Persons

     Persons = Range("A1").Resize(4, 6).Value                   'read the names of your 24 persons
     ReDim Rand(1 To UBound(Persons), 1 To UBound(Persons, 2))  'make the "Random" array, size equal to "persons"
     Randomize
     For i = 1 To UBound(Rand)
          For j = 1 To UBound(Rand, 2)
               Rand(i, j) = Rnd()                               'fill every element with a random value 0-1
          Next
     Next

     For i = 1 To UBound(Result)                                'loop through the persons
          a = Application.Index(Rand, i, 0)                     'take a row from your RandomArray
          For j = 1 To UBound(Result, 2)                        'loop for 4 draws of a name in that group
               r = Application.Match(WorksheetFunction.Small(a, j), a, 0)     'position of the j-smallest number in that row
               Result(i, j) = Persons(i, r)                     'that random person
          Next
     Next

     Range("A1").Offset(, 6).Resize(UBound(Result), UBound(Result, 2)).Value = Result     'write result to sheet
End Sub

Map1
	A	B	C	D	E	F	G	H	I	J
1	a1	a2	a3	a4	a5	a6	a2	a5	a3	a4
2	b1	b2	b3	b4	b5	b6	b3	b6	b4	b5
3	c1	c2	c3	c4	c5	c6	c2	c3	c1	c5
4	d1	d2	d3	d4	d5	d6	d4	d5	d6	d2
Blad1

 

[vannirae]

you want 1 draw or you want 250 ?

Sub Draw_4by4()
     Dim Result(1 To 4, 1 To 4), Rand, Persons

     Persons = Range("A1").Resize(4, 6).Value                   'read the names of your 24 persons
     ReDim Rand(1 To UBound(Persons), 1 To UBound(Persons, 2))  'make the "Random" array, size equal to "persons"
     Randomize
     For i = 1 To UBound(Rand)
          For j = 1 To UBound(Rand, 2)
               Rand(i, j) = Rnd()                               'fill every element with a random value 0-1
          Next
     Next

     For i = 1 To UBound(Result)                                'loop through the persons
          a = Application.Index(Rand, i, 0)                     'take a row from your RandomArray
          For j = 1 To UBound(Result, 2)                        'loop for 4 draws of a name in that group
               r = Application.Match(WorksheetFunction.Small(a, j), a, 0)     'position of the j-smallest number in that row
               Result(i, j) = Persons(i, r)                     'that random person
          Next
     Next

     Range("A1").Offset(, 6).Resize(UBound(Result), UBound(Result, 2)).Value = Result     'write result to sheet
End Sub

Map1
	A	B	C	D	E	F	G	H	I	J
1	a1	a2	a3	a4	a5	a6	a2	a5	a3	a4
2	b1	b2	b3	b4	b5	b6	b3	b6	b4	b5
3	c1	c2	c3	c4	c5	c6	c2	c3	c1	c5
4	d1	d2	d3	d4	d5	d6	d4	d5	d6	d2
Blad1

250 draws with no duplicates

 

[BSALV]

Sub Draw_4by4()
     Dim Result(1 To 4, 1 To 4), Rand, Persons, Dict

     Set Dict = CreateObject("scripting.dictionary")

     Persons = Range("A1").Resize(4, 6).Value                   'read the names of your 24 persons
     ReDim Rand(1 To UBound(Persons), 1 To UBound(Persons, 2))  'make the "Random" array, size equal to "persons"
     Range("M1").EntireColumn.ClearContents

     For ptr = 1 To 20000
          Randomize
          For i = 1 To UBound(Rand)
               For j = 1 To UBound(Rand, 2)
                    Rand(i, j) = Rnd()                          'fill every element with a random value 0-1
               Next
          Next

          For i = 1 To UBound(Result)                           'loop through the persons
               a = Application.Index(Rand, i, 0)                'take a row from your RandomArray
               For j = 1 To UBound(Result, 2)                   'loop for 4 draws of a name in that group
                    R = Application.Match(WorksheetFunction.Small(a, j), a, 0)     'position of the j-smallest number in that row
                    Result(i, j) = Persons(i, R)                'that random person
               Next
          Next

          With Range("AA1").Resize(4, 2)
               .Value = Application.Transpose(Application.Index(Result, 1, 0))
               .Offset(, 1).Resize(, 1).Value = [row(1:4)]
               .Sort .Range("A1"), Header:=xlNo
               x = Application.Transpose(.Offset(, 1).Resize(, 1).Value)
          End With

          s = ""
          For i = 1 To UBound(x)
               s = s & "|" & Join(Application.Transpose(Application.Index(Result, 0, x(i))), ";")
          Next
          s = Mid(s, 2)
          If Not Dict.exists(s) Then
               Dict(s) = s
               Range("M1").Offset(, 1).Resize(, 3).Value = Array(ptr, Dict.Count, ptr - Dict.Count)
               If Dict.Count >= 250 Then Exit For
          End If
         Range("A1").Offset(, 6).Resize(UBound(Result), UBound(Result, 2)).Value = Result     'write result to sheet
     Next

     With Range("M1")
          .Resize(Dict.Count).Value = Application.Transpose(Dict.keys)
          .EntireColumn.AutoFit
          .Offset(, 1).Resize(, 2).Value = Array(ptr, Dict.Count)
     End With



End Sub