从列表中随机选择

Question

我有一个Excel工作表中的项目列表，A1-B115。目前我可以输入10个变量，从列表中检索正确的数据。

现在代码：

C1 = 1 - 通过A1-A115并检查值是否在1000-2000之间;如果是这样，请将B值复制到某处。

C2 = 1 - 通过A1-A115并检查值是否在2001-3000之间;如果是这样，请将B值复制到某处。

....

我想做的是我可以输入一个值（例如：25或30）并且我的宏随机选择适当数量的值。

我想做的代码：C1：30 - >从B1-B115中随机选择30个值

Answer 1

这样就可以了。

Sub PickRandomItemsFromList()

    Const nItemsToPick As Long = 10
    Const nItemsTotal As Long = 115

    Dim rngList As Range
    Dim varRandomItems() As Variant
    Dim i As Long

    Set rngList = Range("B1").Resize(nItemsTotal, 1)

    ReDim varRandomItems(1 To nItemsToPick)
    For i = 1 To nItemsToPick
        varRandomItems(i) = rngList.Cells(Int(nItemsTotal * Rnd + 1), 1)
    Next i
    ' varRandomItems now contains nItemsToPick random items from range rngList. 
End Sub

正如评论中所讨论的，这将允许在挑选的nItemsToPick中多次挑选单个项目，例如，如果编号63恰好被随机挑选两次。如果您不希望发生这种情况，则必须添加一个额外的循环来检查要拾取的项目是否已经在列表中，例如：

Sub PickRandomItemsFromList()

    Const nItemsToPick As Long = 10
    Const nItemsTotal As Long = 115

    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 Then
                Exit Do
            End If
        Loop
        varRandomItems(i) = rngList.Cells(idx(i), 1)
    Next i

    ' varRandomItems now contains nItemsToPick unique random 
    ' items from range rngList. 
End Sub

请注意，如果nItemsToPick > nItemsTotal，这将永远循环！

Answer 2

我会使用一个集合来确保你没有得到任何重复。

Function cItemsToPick(NrOfItems As Long, NrToPick As Long) As Collection
    Dim cItemsTotal As New Collection
    Dim K As Long
    Dim I As Long

    Set cItemsToPick = New Collection

    If NrToPick > NrOfItems Then Exit Function

    For I = 1 To NrOfItems
        cItemsTotal.Add I
    Next I

    For I = 1 To NrToPick
        K = Int(cItemsTotal.Count * Rnd + 1)
        cItemsToPick.Add cItemsTotal(K)
        cItemsTotal.Remove (K)
    Next I
    Set cItemsTotal = Nothing
End Function

您可以使用以下代码测试此函数：

Sub test()
    Dim c As New Collection
    Dim I As Long

    Set c = cItemsToPick(240, 10)
    For I = 1 To c.Count
        Debug.Print c(I)
    Next I
End Sub