dimanche 9 janvier 2022

Display random unique possibilities from rows from a table

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" 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 fit specific criteria.

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

I have been trying to freestyle with the little knowledge that I have and have the below so far. I am not sure if I am going in the right direction.

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



Aucun commentaire:

Enregistrer un commentaire