Need help creating a unique list filled with random picks each based on different criteria

[nikita23]

Hi all, I have faced some difficulties in completing the vba code to create a unique list consisting of random picks each based on different criteria. I am new to vba and macro and would greatly appreciate any help.

To further explain what I require

Level	Required Picks	Conditions >=	Conditions <
WM	1	13	15
SMC	2	11	15
SS	1	7	15
FMP	1	5	9
R	4	3	15

I have a list of unique numbers that form the population in sSheet.Range("A1:A42")
13.01, 14.02, 14.03, 13.04, 12.06. 12.07, 11.08, 11.09, 4.11, 3.12, 9.13, 2.16, 1.17, 2.19, 7.2, 8.21, 8.22, 7.23, 7.24, 7.25, 6.26, 8.27, 10.28, 7.29, 10.3

Other than the required picks ( total = 9), the remainder of the population will be randomly rearranged.
I would have to repeat this picking process for multiple columns hence the vba coding. However, this excel workbook is currently a test and only consist of 1 column (column "A").

I have managed to achieve the picking process for each level, but I am unable to ensure that the picks are unique across the entire lists due to overlapping conditions.
Any advise or help would be greatly appreciated as I feel like I'm so close yet so far to completing it.
THANK YOU VERY MUCH.

Sub macro()
  Dim rCell As Range
  Dim rRng As Range
  Dim rangelist As String
  Dim entryCount As Long
  Dim totalnum As Long
  Dim sSheet As Worksheet
  Dim EndRow As Long
 
  Set sSheet = ThisWorkbook.Sheets("TrlAvailC$")
  EndRow = sSheet.Range("A1:A42").Find("").Row - 1
 
  Set rRng = sSheet.Range("A1:A" & EndRow)

 
  Dim CntWM As Long
  Dim WMmin As Long
  Dim WMmax As Long


  Dim CntSMC As Long
  Dim SMCmin As Long
  Dim SMCmax As Long


  Dim CntFMP As Long
  Dim FMPmin As Long
  Dim FMPmax As Long
 
 
  Dim CntSS As Long
  Dim SSmin As Long
  Dim SSmax As Long
 
  Dim CntR As Long
  Dim Rmin As Long
  Dim Rmax As Long
 
 
  'Set total number of results to return
  totalnum = EndRow


  'Set minimum quantity of each level returned in results
  CntWM = 1
  CntSMC = 2
  CntSS = 1
  CntFMP = 1
  CntR = 4


  'Set min and max salary ranges to return for each Level
  WMmin = 13
  WMmax = 15
  SMCmin = 11
  SMCmax = 15
  SSmin = 7
  SSmax = 15
  FMPmin = 5
  FMPmax = 9
  Rmin = 3
  Rmax = 15


  'Get total number of entries
  entryCount = rRng.Count

  'Randomly get first required Level entries

  'Return list of rows for each Level
  WMList = PickRandomItemsFromList(CntWM, entryCount, WMmin, WMmax)
  SMCList = PickRandomItemsFromList(CntSMC, entryCount, SMCmin, SMCmax)
  SSList = PickRandomItemsFromList(CntSS, entryCount, SSmin, SSmax)
  FMPList = PickRandomItemsFromList(CntFMP, entryCount, FMPmin, FMPmax)
  RList = PickRandomItemsFromList(CntR, entryCount, Rmin, Rmax)

  For Each i In WMList
    If rangelist = "" Then
        rangelist = "A" & i
    Else
        rangelist = rangelist & "," & "A" & i
    End If
  Next i

  For Each i In SMCList
    If rangelist = "" Then
        rangelist = "A" & i
    Else
        rangelist = rangelist & "," & "A" & i
    End If
  Next i

  For Each i In SSList
    If rangelist = "" Then
        rangelist = "A" & i
    Else
        rangelist = rangelist & "," & "A" & i
    End If
  Next i

  For Each i In FMPList
    If rangelist = "" Then
        rangelist = "A" & i
    Else
        rangelist = rangelist & "," & "A" & i
    End If
  Next i
 
    For Each i In RList
    If rangelist = "" Then
        rangelist = "A" & i
    Else
        rangelist = rangelist & "," & "A" & i
    End If
  Next i
 
 
  'Print the rows that match criteria
  Dim rCntr As Long
  rCntr = 1

  Dim nRng As Range
  Set nRng = Range(rangelist)

  For Each j In nRng
 
  'paste third column
    Range(j, j.Offset(0, 2)).Select
    Selection.Copy
    
    'copy dest
    Range("E" & rCntr).Select
    ActiveSheet.Paste
    rCntr = rCntr + 1
  Next j

  'Get rest of rows randomly and print
  LevelList = PickRandomItemsFromListB(totalnum - rCntr + 1, entryCount, rangelist)

  For Each k In LevelList
    Set Rng = Range("A" & k)
    Range(Rng, Rng.Offset(0, 2)).Select
    Selection.Copy
    Range("E" & rCntr).Select
    ActiveSheet.Paste
    rCntr = rCntr + 1
  Next k
 

End Sub


Function PickRandomItemsFromListB(nItemsToPick As Long, nItemsTotal As Long, avoidRng As String)
  Dim rngList As Range
  Dim idx() As Long
  Dim varRandomItems() As Variant
  Dim i As Long
  Dim j As Long
  Dim booIndexIsUnique As Boolean

  Set rngList = Range("A1").Resize(nItemsTotal, 1)

  ReDim idx(1 To nItemsToPick)
  ReDim varRandomItems(1 To nItemsToPick)
  For i = 1 To nItemsToPick
    Do
        booIndexIsUnique = True ' Innoncent until proven guilty
        idx(i) = Int(nItemsTotal * Rnd + 1)
        For j = 1 To i - 1
            If idx(i) = idx(j) Then
                ' It's already there.
                booIndexIsUnique = False
                Exit For
            End If
        Next j

        Set isect = Application.Intersect(Range("A" & idx(i)), Range(avoidRng))

        If booIndexIsUnique = True And isect Is Nothing Then
            Exit Do
        End If
    Loop
    varRandomItems(i) = idx(i)
  Next i

  PickRandomItemsFromListB = varRandomItems
  ' varRandomItems now contains nItemsToPick unique random
  ' items from range rngList.
End Function

Function PickRandomItemsFromList(nItemsToPick As Long, nItemsTotal As Long, Levelmin As Long, Levelmax As Long)
  Dim rngList As Range
  Dim idx() As Long
  Dim varRandomItems() As Variant
  Dim i As Long
  Dim j As Long
  Dim booIndexIsUnique As Boolean

  Set rngList = Range("A1").Resize(nItemsTotal, 1)

  ReDim idx(1 To nItemsToPick)
  ReDim varRandomItems(1 To nItemsToPick)
  For i = 1 To nItemsToPick
    Do
        booIndexIsUnique = True ' Innoncent until proven guilty
        idx(i) = Int(nItemsTotal * Rnd + 1)
        For j = 1 To i - 1
            If idx(i) = idx(j) Then
                ' It's already there.
                booIndexIsUnique = False
                Exit For
            End If
        Next j
        If booIndexIsUnique = True And Range("A" & idx(i)).Value >= Levelmin And Range("A" & idx(i)).Value < Levelmax Then
            Exit Do
        End If
    Loop
    varRandomItems(i) = idx(i)
  Next i

  PickRandomItemsFromList = varRandomItems
End Function