Displaying random unique possibilities from rows from a table until it meets conditions

[beginnervba]

I want to display random different possibilities from a specific data table. I am trying to grab random unique (cannot be used more than once) IDs from column "A" (about 100 IDs in this field), and making sure criteria is met from columns "B"

ID	Colour	Number
111	Red	1.5
112	Blue	2
113	Green	1
114	Blue	1.5
115	Yellow	2
116	Blue	1

and "C"(Usually only whole number or .5 decimal numbers).
Example list below, but very shortened format. I want to have total number (column "C") equal 19.5 or 20, and have:

1. Red from column "B" to be > 5 in column "C".
2. Green from column "B" have at least 2 in column "C"
3. Yellow from column "C" cannot be more than 7 in column "C"

I want it so that every time I press a button, it will have another random possibility to meet a specific criteria.

I have been trying to freestyle with the little knowledge that I have and have the below so far. I think it is completely wrong, but I was wondering if this was in the right direction (What loop should I be doing etc. ).

Sub RandomPossibilities()

Dim NoOfIDs As Long
Dim RandomNumber As Integer
Dim IDs(), Colour() As String 
Dim i As Byte
Dim CellsOut As Long 
Dim ArI As Byte 
Dim RedCount, BlueCount, YellowCount, GreenCount, TotalCount As Variant

Application.ScreenUpdating = False
RedCount = 0
BlueCount = 0
GreenCount = 0
YellowCount = 0
TotalCount = 0
CellsOut = 6
ReDim IDs(1 To 20) 
ReDim Colour(1 To 20)
NoOfIDs = Application.CountA(Range("A:A")) - 1 

i = 1
Do Until (TotalCount = 20 Or TotalCount = 19.5) And RedCount >= 5 And GreenCount >= 2 And YellowCount <= 7

RandomNo:
    RandomNumber = Application.RandBetween(2, NoOfIDs + 1)
    For ArI = LBound(IDs) To UBound(IDs)
        If IDs(ArI) = Cells(RandomNumber, 1).Value Then
            GoTo RandomNo
        End If
        If Cells(RandomNumber, 2).Value = "Not Available"
            GoTo RandomNo
        End If
     Next ArI
    
 IDs(i) = Cells(RandomNumber, 1).Value 
 Colour(i) = Cells(RandomNumber, 2).Value
    
 If Cells(RandomNumber, 2).Value = "Red" Then
     RedCount = RedCount + Cells(RandomNumber, 3).Value
 ElseIf Cells(RandomNumber, 2).Value = "Yellow" Then
     YellowCount = YellowCount + Cells(RandomNumber, 3).Value
 ElseIf Cells(RandomNumber, 2).Value = "Blue" Then
     BlueCount = BlueCount + Cells(RandomNumber, 3).Value
 ElseIf Cells(RandomNumber, 2).Value = "Green" Then
     GreenCount = GreenCount + Cells(RandomNumber, 3).Value
 End If
    

 If TotalCount = 20 Or TotalCount = 19.5 Then
    If RedCount >= 5 Then
       i = 0
       RedCount = 0
       BlueCount = 0
       GreenCount = 0
       YellowCount = 0
       TotalCount = 0
    End If
    If GreenCount >= 2 Then
       i = 0
       RedCount = 0
       BlueCount = 0
       GreenCount = 0
       YellowCount = 0
       TotalCount = 0
    End If
    If YellowCount <= 7 Then
       i = 0
       RedCount = 0
       BlueCount = 0
       GreenCount = 0
       YellowCount = 0
       TotalCount = 0
    End If
 End If
    
 If TotalCount >= 9 Then
    If RedCount >= 5 Then
       i = 0
       RedCount = 0
       BlueCount = 0
       GreenCount = 0
       YellowCount = 0
       TotalCount = 0
    End If
 If GreenCount >=2 Then
       i = 0
       RedCount = 0
       BlueCount = 0
       GreenCount = 0
       YellowCount = 0
       TotalCount = 0
 End If
 If YellowCount <=7 2 Then
       i = 0
       RedCount = 0
       BlueCount = 0
       GreenCount = 0
      YellowCount = 0
       TotalCount = 0
    End If
       i = 0
       RedCount = 0
       BlueCount = 0
       GreenCount = 0
       YellowCount = 0
    TotalCount = 0
 End If
    i = i + 1

TotalCount = GreenCount + BlueCount + YellowCount + RedCount
    
Loop


For ArI = LBound(IDs) To UBound(IDs)
    Cells(CellsOut + 2, 6) = IDs(ArI)
    Cells(CellsOut + 2, 7) = Colour(ArI)
    CellsOut = CellsOut + 1
Next ArI
Cells(8, 9) = YellowCount
Cells(9, 9) = BlueCount
Cells(10, 9) = GreenCount
Cells(11, 9) = RedCount
Cells(12, 9) = TotalCount
Application.ScreenUpdating = True
End Sub

 

[BSALV]

Option Compare Text

Sub RandomPos()
     Dim Output(), bRed, iRed, bBlue, IBlue, bYellow, iYellow, iGreen, bGreen
     With Range("A1").CurrentRegion
          arr = .Offset(1).Resize(.Rows.Count - 1, 3).Value     'read your data to an array, x rows * 3 columns width
     End With

     Do
          ptr = ptr + 1
          DoEvents

          ReDim Output(1 To 20, 1 To 5)
          rand = Application.WorksheetFunction.RandArray(UBound(arr) - 1)     ' array with x random numbers between 0 and 1
          For i = 1 To UBound(Output)                           'unique random select 20 numbers
               r = Application.Match(WorksheetFunction.Small(rand, i), rand, 0)     'position of the 1-smallest number in your list
               Output(i, 1) = arr(r, 1)                         'random name
               Select Case arr(r, 2)                            'select on color
                    Case "Red": Output(i, 2) = arr(r, 3)        '2nd column
                    Case "Blue": Output(i, 3) = arr(r, 3)       '3rd column
                    Case "Yellow": Output(i, 4) = arr(r, 3)     '4th column
                    Case "Green": Output(i, 5) = arr(r, 3)      '4th column
                    Case Else: MsgBox "wrong color " & arr(r, 2)
               End Select
          Next
          Range("E4").Resize(UBound(Output), UBound(Output, 2)).Value = Output

          iRed = Application.Sum(Application.Index(Output, 0, 2)): bRed = (iRed > 5)
          iGreen = Application.Sum(Application.Index(Output, 0, 5)): bGreen = (iGreen > 2)
          iYellow = Application.Sum(Application.Index(Output, 0, 4)): bYellow = (iYellow <= 7)

     Loop While (Not bRed Or Not bGreen Or Not bYellow) And ptr < 1000
     
     If bRed + bGreen + bYellow <> -3 Then MsgBox "no combination found after " & ptr & " loops" Else MsgBox "ready after " & ptr & " loops "

End Sub

Map1
	A	B	C	D	E	F	G	H	I	J
1	ID	Colour	Number		count	3	14	0	3
2	111	Red	1,5		sum	6	24	0	4
3	112	Blue	2		ID	Red	Blue	Yellow	green
4	113	Green	1		209		1
5	114	Blue	1,5		143		2
6	115	Yellow	2		180		2
7	116	Blue	1		156	2
Blad2

Cell Formulas
Range	Formula
F1:I1	F1	=COUNT(F$4:F$23)
F2:I2	F2	=SUM(F$4:F$23)

 

[BSALV]

error : it's not -1, so delete that part

rand = Application.WorksheetFunction.RandArray(UBound(arr) - 1)     ' array with x random numbers between 0 and 1
correct :
rand = Application.WorksheetFunction.RandArray(UBound(arr) )

 

[beginnervba]

error : it's not -1, so delete that part

rand = Application.WorksheetFunction.RandArray(UBound(arr) - 1)     ' array with x random numbers between 0 and 1
correct :
rand = Application.WorksheetFunction.RandArray(UBound(arr) )

Thanks for the quick reply!

I am getting error "Unable to get the RandArray property of the WorksheetFunction class" and the code above highlighted. I was wondering if i did something wrong?

 

[BSALV]

indeed, randarray is for newer excelversions, solution, make that array yourself with a small loop

Option Compare Text

Sub RandomPos()

     Dim Output(), bRed, iRed, bBlue, IBlue, bYellow, iYellow, iGreen, bGreen, rand()
     
     With Range("A1").CurrentRegion
          arr = .Offset(1).Resize(.Rows.Count - 1, 3).Value     'read your data to an array, x rows * 3 columns width
     End With

     ReDim rand(1 To UBound(arr))                               'make array so big

     Do
          ptr = ptr + 1
          DoEvents

          ReDim Output(1 To 20, 1 To 5) 'clear preivous Output
          Randomize                                             'randomizer
          For i = 1 To UBound(rand): rand(i) = Rnd: Next        'fill yourself that array with x random numbers

          For i = 1 To UBound(Output)                           'unique random select 20 numbers
               r = Application.Match(WorksheetFunction.Small(rand, i), rand, 0)     'position of the 1-smallest number in your list
               Output(i, 1) = arr(r, 1)                         'random name
               Select Case arr(r, 2)                            'select on color
                    Case "Red": Output(i, 2) = arr(r, 3)        '2nd column
                    Case "Blue": Output(i, 3) = arr(r, 3)       '3rd column
                    Case "Yellow": Output(i, 4) = arr(r, 3)     '4th column
                    Case "Green": Output(i, 5) = arr(r, 3)      '4th column
                    Case Else: MsgBox "wrong color " & arr(r, 2)
               End Select
          Next
          Range("E4").Resize(UBound(Output), UBound(Output, 2)).Value = Output

          iRed = Application.Sum(Application.Index(Output, 0, 2)): bRed = (iRed > 5)
          iGreen = Application.Sum(Application.Index(Output, 0, 5)): bGreen = (iGreen > 2)
          iYellow = Application.Sum(Application.Index(Output, 0, 4)): bYellow = (iYellow <= 7)

     Loop While (Not bRed Or Not bGreen Or Not bYellow) And ptr < 1000

     If bRed + bGreen + bYellow <> -3 Then MsgBox "no combination found after " & ptr & " loops" Else MsgBox "ready after " & ptr & " loops "

End Sub