4

私は、ランダムなテストのために一連の従業員 ID 番号をランダムに選択するマクロに取り組んでいます。返される最初の数値が常に同じであることを除いて、私が持っているコードはうまく機能します。たとえば、ID 番号が 1 ～ 100 で、10 個の乱数が必要な場合、最初の数字は常に 1 になり、その後はランダムになります。

追加の課題として、リストが循環するまで同じ番号が選択されないようにすることは可能ですか?

これが私が使用しているコードです。

Sub Macro1()
   '
   '
   '
'
 Dim CountCells
 Dim RandCount
Dim LastRow
Dim Counter1
Dim Counter2
Worksheets.Add().Name = "Sheet1"
Worksheets("Employee ID#").Select
 Range("a2:A431").Select
Selection.Copy
Worksheets("Sheet1").Select
Selection.PasteSpecial

Worksheets("Sheet1").Select
Range("A1").Select
CountCells = WorksheetFunction.Count(Range("A:A")) 'quantity of random numbers to pick from
If CountCells = 0 Then Exit Sub
On Error Resume Next
Application.DisplayAlerts = False
RandCount = Application.InputBox(Prompt:="How many random numbers do you want?", _
      Title:="Random Numbers Selection", Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
RandCount = Int(RandCount)
If Int(RandCount) <= 0 Or RandCount = False Then Exit Sub
If RandCount > CountCells Then
    MsgBox "Requested quantity of numbers is greater than quantity of available data"
    Exit Sub
End If


LastRow = Cells(Rows.Count, "A").End(xlUp).Row
'clear working area
Range("B:C").ClearContents
'clear destination area
Range("Sheet2!A:A").ClearContents
'create index for sort use
Range("B1") = 1
Range(Cells(1, 2), Cells(LastRow, 2)).DataSeries , Step:=1
'create random numbers for sort
Range("C1") = "=RAND()"
Range("C1").Copy Range(Cells(1, 3), Cells(LastRow, 3))
'randomly sort data
Range(Cells(1, 1), Cells(LastRow, 3)).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'data has been sorted randomly, cells in column A, rows 1 through the quantity desired will be chosen
Counter1 = 1
Counter2 = 1
Do Until Counter1 > RandCount
    If IsNumeric(Cells(Counter2, 1).Value) And Cells(Counter2, 1).Value <> Empty Then
        Range("Sheet2!A" & Counter1) = Cells(Counter2, 1).Value
        Counter1 = Counter1 + 1
        'Selection.ClearContents
    End If
    Counter2 = Counter2 + 1

Loop
'resort data into original order and clear working area
Range(Cells(1, 1), Cells(LastRow, 3)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("B:C").ClearContents
Sheets("Sheet2").Select
'Sheets("Sheet2").PrintOut





End Sub

助けてくれてありがとう。

4

1 に答える 1

7

Randomize別の最初の番号を取得するには、関数の先頭に次の行を追加するだけです。

従業員のリストを配列にロードし、従業員が選択されたら、従業員を配列から削除して、再度選択できないようにすることができます。

-編集-

私はあなたのために働くはずのこのコードを思いつきました。従業員 ID 番号を配列にロードするので、時間のかかるセルの選択と再配置に対処する必要はありません。次に、コードはすべての従業員の配列から従業員を選択し、それらを従業員の配列に追加してチェックします。次に、すべての従業員の配列から従業員を削除して、再度選択できないようにします。コードがチェックする必要な従業員数を選択すると、目的のシートにそれらを書き込みます。

Sub SelectRandomEntries()

    Dim WSEmp As Worksheet
    Dim WSCheckedEmps As Worksheet
    Dim AllEmps() As Long 'An array to hold the employee numbers
                         'Assuming Column A is an integer employee #
    Dim CheckedEmps() As Long
    Dim FirstRow As Long
    Dim LastRow As Long
    Dim RandCount As Long
    Dim RandEmp As Long
    Dim i As Long

    'Set the worksheets to variables.  Make sure they're set to the appropriate sheets in YOUR workbook.
    Set WSEmp = ThisWorkbook.Worksheets("Employee ID#") 'Sheet with all employees
    Set WSCheckedEmps = ThisWorkbook.Worksheets("Checked Employees") 'Sheet with checked employees
    FirstRow = 1
    LastRow = WSEmp.Cells(WSEmp.Rows.Count, "A").End(xlUp).Row 'Find the last used row in a ColumnA

    Randomize 'Initializes the random number generator.

    'Load the employees into an array
    ReDim AllEmps(FirstRow To LastRow) 'Make the array large enough to hold the employee numbers
    For i = FirstRow To LastRow
        AllEmps(i) = WSEmp.Cells(i, 1).Value
    Next

    'For this example, I sent RandCount to a random number between the first and last entries.
    'Rnd() geneates a random number between 0 and 1 so the rest of line converts it to a usable interger.
    RandCount = Int((LastRow - FirstRow + 1) * Rnd() + FirstRow)
    MsgBox (RandCount & "will be checked")
    ReDim CheckedEmps(1 To RandCount)

    'Check random employees in the array
    For i = 1 To RandCount
        RandEmp = Int((LastRow - FirstRow + 1) * Rnd() + FirstRow) 'pick a random employee to check
        If IsNumeric(AllEmps(RandEmp)) And AllEmps(RandEmp) <> Empty Then 'If the emp# is valid
            CheckedEmps(i) = AllEmps(RandEmp) 'Move the employee to the checked employee list.
            AllEmps(RandEmp) = Empty 'Clear the employee from the full list so they can't get picked again
        Else
            i = i - 1 'If you checked a RandEmp that wasn't suitable, you'll need to check another one.
        End If
    Next

    'Write the employees to the results sheet
    For i = 1 To RandCount
        WSCheckedEmps.Cells(i, 1) = CheckedEmps(i)
    Next i

End Sub

データセットに特に関連するチェックを追加する必要がある場合があり (私はほんの一握りのランダムな整数を使用しました)、チェックする従業員の数を人々が選択できるようにする方法を再実装する必要があります。

于 2013-06-11T14:54:12.403 に答える