PDA

View Full Version : Random with critaria



Limortz
10-02-2018, 02:18 AM
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
10-02-2018, 02:39 AM
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
10-02-2018, 04:02 AM
22965

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
10-02-2018, 08:58 AM
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
12-04-2018, 08:07 AM
I forgot to thank you ! that was very helpful !