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?

 

[vannirae]

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

I am unsure how to make this work with my page. Can I send the file to you and you can add it?

 

[vannirae]

I am unsure how to make this work with my page. Can I send the file to you and you can add it?

I believe I have Office 16

 

[BSALV]

an adapted macro example file

Public Const iDrawings = 250

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

     Set Dict = CreateObject("scripting.dictionary")            'prepare the dictionary (to avoid duplicates)
     Application.ScreenUpdating = False
     t = Timer
     '**************************************
     'Where is my data located ?   ----> CHANGE HERE
     '**************************************
     Set c1 = Range("A1")                                       'topleftcell with the names of your 24 persons
     Set c2 = Range("AA1").Resize(4, 2)                         '8 auxiliary cells for alphabetic sorting the 1st group
     Set c3 = Range("AD3")                                      '1st cell where you write the unique combinations


     Persons = c1.Resize(4, 6).Value                            'read the names of your 24 persons 4*6
     ReDim Rand(1 To UBound(Persons), 1 To UBound(Persons, 2))  'make the "Random" array, size equal to "persons"
     c3.Resize(Rows.Count - c3.Row + 1, 20).ClearContents       'clear content of previous result

     For ptr = 1 To 1000                                        '1,000 loops (exagerated)
          Application.StatusBar = "loop   " & ptr: DoEvents
     ' take 24 random numbers between 0 and 1 in an array of 4*6
          Randomize                                             'better random result
          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

     'in a group of 6 persons, take random 4 persons without repetition = find the position of the first 4 smallest values
          For i = 1 To UBound(Result)                           'loop through the 4 groups
               a = Application.Index(Rand, i, 0)                'take a row from your RandomArray (= 6 random number of the 6 persons in a group)
               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

     '***********************************************
     '1st update to the worksheet : the 16 names without duplicates
     '************************************************
          c1.Offset(, 6).Resize(UBound(Result), UBound(Result, 2)).Value = Result     'write result to sheet just aside the 24 names

     '*************************************************************************************************************
     'to check if the found combination is unique and not a rotation of a previous draw, sort the 1st group alphabetic and join then the names in a string
     'if that string is unique (=doesn't exisit in the dictionary) then the draw is unique
     '*************************************************************************************************************
          With c2
               .Value = Application.Transpose(Application.Index(Result, 1, 0))     'the 4 drawn names of group1
               .Offset(, 1).Resize(, 1).Value = [row(1:4)]      'numbers 1-4
               .Sort .Range("A1"), Header:=xlNo                 'sort the names alphabetic
               x = Application.Transpose(.Offset(, 1).Resize(, 1).Value)     'read the result in array x
          End With
          s1 = "": s2 = ""                                      'start with 2 empty strings, the 1st is sorted for the dictionary (better check on duplicates), the 2nd is unsorted for the sheet
          For i = 1 To UBound(x)
               s1 = s1 & "|" & Join(Application.Transpose(Application.Index(Result, 0, x(i))), "|")     'sorted
               s2 = s2 & "|" & Join(Application.Transpose(Application.Index(Result, 0, i)), "|")     'unsorted
          Next
          s1 = Mid(s1, 2): s2 = Mid(s2, 2)                      'delete the leading "|"
          If Not Dict.exists(s) Then                            'combination is unique, was almost certain !!! there are too much combinations, the chance of a duplicate is almost 0.
               Dict(s1) = s1                                    'add to dictionary
               c3.Offset(Rows.Count - c3.Row).End(xlUp).Offset(1).Value = s2     'write the unsorted string to the sheet
               If Dict.Count >= iDrawings Then Exit For         '250 unique drawns found = stop loop
          End If
     Next

     '********************************
     'split the found solution into individual cells
     '********************************
     With c3.Resize(iDrawings)                                  'your 250 drawns
          Application.DisplayAlerts = False
          .TextToColumns .Range("b1"), xlDelimited, xlDoubleQuote, False, False, False, False, False, other:=True, OtherChar:="|"     'split on the "|"-character
          Application.DisplayAlerts = True
          .Resize(, 17).EntireColumn.AutoFit                    'adjust columnwidth
     End With

     Application.StatusBar = "l"
     'MsgBox Timer - t'read chronometer

End Sub