0

1 つの列に 100 の名前があります。次のセルの各名前の横には、その名前の価値を表す数値が表示されます。会社には、各名前が潜在的に持つ可能性のある 6 つの役職があります。そして、それは各名前の横のセルにもあります。

したがって、スプレッドシートは次のようになります。

ジョン・スミス弁護士 $445352

ジョー・ドゥ・ドクター $525222

John Doe 会計士 $123192

等....

合計で 200 万ドルから 300 万ドルの収入を得ている 10 人を Excel に提供してもらいたいです。しかし、2 人は医師、2 人は弁護士、2 人は会計士などである必要があります。どのように作成すればよいでしょうか?

4

1 に答える 1

0

次のデータを使用してシート 1 を設定します。

ここに画像の説明を入力

ゴール：

  1. 10人を返す
  2. 給与100万～600万程度
  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 人いない場合や、必要な数の結果を満たすのに十分なエントリが残っていない場合にどうなるかなど、エラー チェックはあまり行っていません。目的に合わせて微調整する必要があります。条件を変更するたびにコードをいじる必要がないように、入力をフォームとして設定することも必要になるでしょう。

于 2013-09-19T16:51:07.513 に答える