Random Sampling Macro multiple criteria and loops - using arrays and dictionary

[Absurdk]

I have two tables, one with multiple rows and columns of information from where I need to pull a random sample of rows according to a second table on a different sheet (the one below)

I've managed to put together some code that allows me to pull a random sample and apply some filters to it before spitting the output. I'm thinking about adding another loop that runs for each person and pulls the number of rows needed depending on the criteria on the table from above but I don't know how to adapt it to what I have right now.

It will have to go name by name and apply the criteria accordingly, so for example. The macro would go and pull 85 random rows that have "US" in column x and 5 random rows that have "CA" in column y, I'm using an array so the idea is to fill the array progressively with the rows that meet the criteria.

Here's the code I have so far, any help would be very much appreciated

Sub distro()
    
    Dim srcWS       As Worksheet
    Dim destWS      As Worksheet
    Dim critWS      As Worksheet
    Dim i           As Long
    Dim usedRowsDic As Object
    Dim outArray()  As Variant
    Dim lastrow     As Long
    Dim bigArray    As Variant
    Dim desiredRecs As Long
    Dim recsGathered As Long
    Dim rec         As Long
    Dim cnty        As Long
    
    Set srcWS = ThisWorkbook.Worksheets("Audit")
    Set destWS = ThisWorkbook.Worksheets("Distro")
    Set critWS = ThisWorkbook.Worksheets("For Distribution And PBI")
    Set usedRowsDic = CreateObject("scripting.dictionary")
    
    'agent variables
    
    Dim agent        As Range
    Dim lastrowu    As Long
    
    lastrowu = Sheets("For Distribution And PBI").Cells(Rows.Count, 1).End(xlUp).Row
    Set agent = Sheets("For Distribution And PBI").Range("B3", "B" & lastrowu).SpecialCells(xlCellTypeVisible)
    
    desiredRecs = critWS.Range("L49").Value
    
    lastrow = srcWS.Range("A" & Rows.Count).End(xlUp).Row
    
    bigArray = srcWS.Range("A1:AH" & lastrow)
    
    ReDim outArray(LBound(bigArray, 1) To desiredRecs, LBound(bigArray, 2) To UBound(bigArray, 2))
    
    'select random records
    
    'Loop per agent
    
    For Each cell In agent
        
        Do Until recsGathered = desiredRecs
            
            Randomize
            rec = WorksheetFunction.RandBetween(LBound(bigArray, 1), UBound(bigArray, 1))
            
            If Not usedRowsDic.exists(rec) And Trim(bigArray(rec, 27)) = "Check" And Trim(bigArray(rec, 24)) = "US" Then
                
                'Increment Counter
                recsGathered = recsGathered + 1
                
                'Add to OutPut Array
                For i = LBound(outArray, 2) To UBound(outArray, 2)
                    outArray(recsGathered, i) = bigArray(rec, i)
                Next i
                
                'Add rec
                usedRowsDic.Add rec, True
            End If
        Loop
    Next cell
    
    'output
    destWS.Range("A2").Resize(desiredRecs, UBound(outArray, 2)).Value = outArray
    '    MsgBox (usedRowsDic.Count)
    Erase outArray
    Erase bigArray
    Set usedRowsDic = Nothing
    Set srcWS = Nothing
    Set destWS = Nothing
    
End Sub