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 !
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.