Random with critaria

[Limortz]

Hi everyone,

Is there a way to choose a number of random different cells from a list (not necessary in VBA), but the chosen cells should be different from each other according to some criteria? the criteria are been shown in the other column of that list.

For example:

Drawing 8 different random names (column A) that are different in their divisions (column B), different start month of employment (column B), gender diversity etc.

Thanks in advance !

[werafa]

You can generate two arrays of random numbers, and use them with the 'Cells' command to generate cell references (using VBA).
test each new combo of numbers for uniqueness and skip any duplicates

You should also be able to use the 'offset' worksheet command to do the same thing without VBA - but you might have trouble enforcing the uniqueness

Werafa

[Limortz]

Copy of BrownBag Example.xlsx

Thanks, would you mind help me with the code for this one? the attached file is an example.
the propose is to choose 8 name from column A , 4 male and 4 female (column B), different Department (column C), different division (column D), different 'Reporting to' (column E) and different Month+ year hire date (column F).

Thanks !
Limor

Department

[Paul_Hossler]

Try something like this

Option Explicit


Const cName As Long = 1
Const cGender As Long = 2
Const cDept As Long = 3
Const cDiv As Long = 4
Const cReports As Long = 5
Const cHire As Long = 6

Dim vData() As Variant

Sub BrownBag()
    Dim rData As Range
    Dim aryRand() As Double, dHold As Double, iHold As Long
    Dim iRow As Long, iCol As Long, i As Long, j As Long
    Dim aryMale(1 To 4) As Long, aryFemale(1 To 4) As Long
    Dim iMale As Long, iFemale As Long
    Dim iRandRow As Long, sGender As String, sMatch As String
    Dim sMessage As String
    
    Set rData = ActiveSheet.Cells(1, 1).CurrentRegion


    'data to array for speed
    ReDim vData(1 To rData.Rows.Count, 1 To 6)

    'standardize data, save row number
    With rData
        For iRow = LBound(vData, 1) To UBound(vData, 1)
            vData(iRow, cName) = iRow
            vData(iRow, cGender) = LCase(.Cells(iRow, cGender).Value)
            vData(iRow, cDept) = LCase(.Cells(iRow, cDept).Value)
            vData(iRow, cDiv) = LCase(.Cells(iRow, cDiv).Value)
            vData(iRow, cReports) = LCase(.Cells(iRow, cReports).Value)
            vData(iRow, cHire) = Format(.Cells(iRow, cHire), "yyyy-mm")
        Next iRow
    End With
    
    'generate random, remember row
    ReDim aryRand(LBound(vData, 1) To UBound(vData, 1), 1 To 2)
    For iRow = LBound(aryRand, 1) To UBound(aryRand, 1)
        aryRand(iRow, 1) = 1000# * Rnd
        aryRand(iRow, 2) = iRow
    Next iRow
    
    'force headers to bottom during sort
    aryRand(1, 1) = 99999999
    
    
    'bubble sort
    For i = LBound(aryRand, 1) To UBound(aryRand, 1) - 1
        For j = i To UBound(aryRand, 1)
            If aryRand(j, 1) < aryRand(i, 1) Then
                dHold = aryRand(i, 1)
                iHold = aryRand(i, 2)
                aryRand(i, 1) = aryRand(j, 1)
                aryRand(i, 2) = aryRand(j, 2)
                aryRand(j, 1) = dHold
                aryRand(j, 2) = iHold
            End If
        Next j
    Next i
    
    'find 4 males and 4 female, start at top
    iMale = 0
    iFemale = 0
    For i = LBound(aryRand, 1) To UBound(aryRand, 1) - 1 '  skip headers at bottom
        
        iRandRow = aryRand(i, 2)
        iRow = vData(iRandRow, 1)
        sGender = vData(iRandRow, 2)
        sMatch = vData(iRandRow, 3)
    
        If sGender = "male" Then
            Select Case iMale
                Case 0
                    aryMale(1) = iRandRow
                    iMale = 1
                Case 1
                    If Not pvtOverlap(iRandRow, aryMale(1)) Then
                        aryMale(2) = iRandRow
                        iMale = 2
                    End If
                Case 2
                    If Not pvtOverlap(iRandRow, aryMale(1)) And Not pvtOverlap(iRandRow, aryMale(2)) Then
                        aryMale(3) = iRandRow
                        iMale = 3
                    End If
                Case 3
                    If Not pvtOverlap(iRandRow, aryMale(1)) And Not pvtOverlap(iRandRow, aryMale(2)) And Not pvtOverlap(iRandRow, aryMale(3)) Then
                        aryMale(4) = iRandRow
                        iMale = 4
                    End If
                Case Else
            End Select
        
        ElseIf sGender = "female" Then
            Select Case iFemale
                Case 0
                    aryFemale(1) = iRandRow
                    iFemale = 1
                Case 1
                    If Not pvtOverlap(iRandRow, aryFemale(1)) Then
                        aryFemale(2) = iRandRow
                        iFemale = 2
                    End If
                Case 2
                    If Not pvtOverlap(iRandRow, aryFemale(1)) And Not pvtOverlap(iRandRow, aryFemale(2)) Then
                        aryFemale(3) = iRandRow
                        iFemale = 3
                    End If
                Case 3
                    If Not pvtOverlap(iRandRow, aryFemale(1)) And Not pvtOverlap(iRandRow, aryFemale(2)) And Not pvtOverlap(iRandRow, aryFemale(3)) Then
                        aryFemale(4) = iRandRow
                        iFemale = 4
                    End If
                Case Else
            End Select
        
        End If
    Next i
            
            
    'pick name
    rData.Interior.ColorIndex = xlColorIndexNone
        
    sMessage = vbNullString
    
    For i = LBound(aryMale) To UBound(aryMale)
        If aryMale(i) > 0 Then
            rData.Cells(aryMale(i), cName).Interior.ColorIndex = 33
            sMessage = sMessage & rData.Cells(aryMale(i), cName).Value & ", "
        End If
    Next i
    
    sMessage = sMessage & vbCrLf & vbCrLf
    
    For i = LBound(aryFemale) To UBound(aryFemale)
        If aryFemale(i) > 0 Then
            rData.Cells(aryFemale(i), cName).Interior.ColorIndex = 7
            sMessage = sMessage & rData.Cells(aryFemale(i), cName).Value & ", "
        End If
    Next i
    MsgBox sMessage
End Sub

Private Function pvtOverlap(v1 As Long, v2 As Long) As Boolean
    Dim i As Long
    
    pvtOverlap = True
            
    For i = cDept To cHire
        If vData(v1, i) = vData(v2, i) Then Exit Function
    Next i
    
    pvtOverlap = False
End Function

[Limortz]

I forgot to thank you ! that was very helpful !