How do I use excel to create random names with values between a certain amount?

Question

I have 100 names in one column. And next to each name in the next cell is a numerical value that the name is worth.There are 6 positions in a company that each name could potentially hold. And that is also in a cell next to each name.

So the spreadsheet looks something like this.

John Smith Lawyer     $445352

Joe Doe    Doctor     $525222

John Doe   Accountant $123192 

etc....

I want excel to give me 10 people who make a combined amount between 2 and 3 million dollars. But I require that 2 of the people be doctors 2 be lawyers and 2 be accountants etc. How would I create this?

Answer 1

I set up sheet 1 with the following data:

Goal:

1. Return 10 people
2. Salary between 1000000 and 6000000 range
3. Min 2 each doc, lawyer, accountant

Run this Macro:

Sub macro()
  Dim rCell As Range
  Dim rRng As Range
  Dim rangelist As String
  Dim entryCount As Long
  Dim totalnum As Long
  Set rRng = Sheet1.Range("A1:A12")

  Dim OccA As String
  Dim OccCntA As Long
  Dim OccASalmin As Long
  Dim OccASalmax As Long

  Dim OccB As String
  Dim OccCntB As Long
  Dim OccBSalmin As Long
  Dim OccBSalmax As Long

  Dim OccC As String
  Dim OccCntC As Long
  Dim OccCSalmin As Long
  Dim OccCSalmax As Long

  'Set total number of results to return
  totalnum = 10

  'Set which occupations that must be included in results
  OccA = "Accountant"
  OccB = "Doctor"
  OccC = "Lawyer"

  'Set minimum quantity of each occupation to me returned in results
  OccCntA = 2
  OccCntB = 2
  OccCntC = 2

  'Set min and max salary ranges to return for each occupation
  OccASalmin = 1000000
  OccASalmax = 6000000
  OccBSalmin = 1000000
  OccBSalmax = 6000000
  OccCSalmin = 1000000
  OccCSalmax = 6000000


  'Get total number of entries
  entryCount = rRng.Count

  'Randomly get first required occupation entries

  'Return list of rows for each Occupation
  OccAList = PickRandomItemsFromList(OccCntA, entryCount, OccA, OccASalmin, OccASalmax)
  OccBList = PickRandomItemsFromList(OccCntB, entryCount, OccB, OccBSalmin, OccBSalmax)
  OccCList = PickRandomItemsFromList(OccCntC, entryCount, OccC, OccCSalmin, OccCSalmax)

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

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

  For Each i In OccCList
    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
    Range(j, j.Offset(0, 2)).Select
    Selection.Copy
    Range("E" & rCntr).Select
    ActiveSheet.Paste
    rCntr = rCntr + 1
  Next j

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

  For Each k In OccList
    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("B1").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, Occ As String, Salmin As Long, Salmax 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("B1").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("B" & idx(i)).Value = Occ And Range("B" & idx(i)).Offset(0, 1).Value >= Salmin And Range("B" & idx(i)).Offset(0, 1).Value <= Salmax     Then
            Exit Do
        End If
    Loop
    varRandomItems(i) = idx(i)
  Next i

  PickRandomItemsFromList = varRandomItems
End Function

Results are printed in column E with the first results meeting the criteria. After those, the rest are random but don't repeat the previous ones:

I'm not doing very much error checking such as what happens if there are not 2 doctors or not enough entries left to meet the required number of results. You'll have to fine tune it for your purposes. You'll probably also want to set up the inputs as a form so you don't have to mess with code every time you change your criteria.