excel - 如何使用 excel 创建具有一定数量值之间的随机名称？

Question

我在一列中有 100 个名字。并且在下一个单元格中的每个名称旁边是该名称的价值。在公司中有 6 个职位可能每个名称都可能担任。这也在每个名称旁边的单元格中。

所以电子表格看起来像这样。

约翰史密斯律师 $445352

乔·多伊医生 $525222

John Doe 会计师 $123192

ETC....

我想让 excel 给我 10 个总收入在 2 到 300 万美元之间的人。但我要求其中 2 人是医生、2 人是律师、2 人是会计师等。我将如何创建这个？

Answer 1

我使用以下数据设置工作表 1：

目标：

1. 返回 10 人
2. 工资在 1000000 到 6000000 之间
3. 每位医生、律师、会计师至少 2 人

运行这个宏：

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

结果打印在 E 列中，第一个结果符合标准。之后，其余的都是随机的，但不要重复前面的：

我没有做太多的错误检查，例如如果没有 2 名医生或没有足够的条目来满足所需的结果数量会发生什么。您必须根据自己的目的对其进行微调。您可能还希望将输入设置为表单，这样您就不必在每次更改条件时都弄乱代码。