Excel 如何随机选择多个单元格并在消息框中显示内容？

我在A1-A37单元有一个身份证号码1101-1137的列表。我想点击一个按钮，随机选择其中20个，没有重复，并显示在一个消息框中

我现在所拥有的似乎是从数字1-37中随机选择的，而不是单元格的实际内容，我不知道如何修复它。例如，如果我从单元格A37中删除编号1137，则编号37仍然可以出现在消息框中；如果我用字母E替换单元格A5中的数字1105，E将不会显示在消息框中，但5可以

但是，如果我将“Const nItemsTotal As Long=37”更改为等于其他数字，比如31，它将只输出1-31之间的数字

这就是我所拥有的：

Private Sub CommandButton1_Click()

Const nItemsToPick As Long = 20
Const nItemsTotal As Long = 37

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("A1").Resize(nItemsTotal, 1)

ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
    Do
        booIndexIsUnique = True ' Innocent 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
        strString = strString & vbCrLf & idx(i)
            Exit Do
        End If
    Loop
    varRandomItems(i) = rngList.Cells(idx(i), 1)

  Next i
    Msg = strString
    MsgBox Msg
' varRandomItems now contains nItemsToPick unique random
' items from range rngList.

End Sub

---

我肯定这是个愚蠢的错误，但我迷路了。非常感谢您的帮助。

我在您的代码中增加了一行。。。现在是：

strString = strString & vbCrLf & Cells(idx(i), 1).Value

完整代码为：

Private Sub CommandButton1_Click()

Const nItemsToPick As Long = 20
Const nItemsTotal As Long = 37

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("A1").Resize(nItemsTotal, 1)

ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
    Do
        booIndexIsUnique = True ' Innocent 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
        strString = strString & vbCrLf & Cells(idx(i), 1).Value
            Exit Do
        End If
    Loop
    varRandomItems(i) = rngList.Cells(idx(i), 1)

  Next i
    Msg = strString
    MsgBox Msg
' varRandomItems now contains nItemsToPick unique random
' items from range rngList.

End Sub

---

因此，它不返回数字，而是使用返回的数字查看与其相关的行上的值。

只需将索引洗牌即可：

Sub MAIN()
   Dim ary(1 To 37) As Variant
   Dim i As Long, j As Long

   For i = 1 To 37
      ary(i) = i
   Next i

   Call Shuffle(ary)

   msg = ""
   For i = 1 To 20
      j = ary(i)
      msg = msg & vbCrLf & Cells(j, 1).Value
   Next i
   MsgBox msg
End Sub



Public Sub Shuffle(InOut() As Variant)
    Dim i As Long, j As Long
    Dim tempF As Double, Temp As Variant

    Hi = UBound(InOut)
    Low = LBound(InOut)
    ReDim Helper(Low To Hi) As Double
    Randomize

    For i = Low To Hi
        Helper(i) = Rnd
    Next i


    j = (Hi - Low + 1) \ 2
    Do While j > 0
        For i = Low To Hi - j
          If Helper(i) > Helper(i + j) Then
            tempF = Helper(i)
            Helper(i) = Helper(i + j)
            Helper(i + j) = tempF
            Temp = InOut(i)
            InOut(i) = InOut(i + j)
            InOut(i + j) = Temp
          End If
        Next i
        For i = Hi - j To Low Step -1
          If Helper(i) > Helper(i + j) Then
            tempF = Helper(i)
            Helper(i) = Helper(i + j)
            Helper(i + j) = tempF
            Temp = InOut(i)
            InOut(i) = InOut(i + j)
            InOut(i + j) = Temp
          End If
        Next i
        j = j \ 2
    Loop
End Sub

---

如果您构建了一个包含通过随机化找到的ID的字符串，您可以检查重复

Dim i As Long, msg As String, id As String

msg = Chr(9)
For i = 1 To 20
    id = 1100 + Int((37 - 1 + 1) * Rnd + 1)
    Do Until Not CBool(InStr(1, msg, Chr(9) & id & Chr(9)))
        Debug.Print id & msg
        id = 1100 + Int((37 - 1 + 1) * Rnd + 1)
    Loop
    msg = msg & id & Chr(9)
Next i
msg = Mid(Left(msg, Len(msg) - 1), 2)

MsgBox msg

另一种方法：

Sub test()
    Dim Dic As Object, i%
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.comparemode = vbTextCompare
    While Dic.Count <> 20
        i = WorksheetFunction.RandBetween(1, 37)
        If Not Dic.exists(i) Then Dic.Add i, Cells(i, "A")
    Wend
    MsgBox Join(Dic.Items, Chr(13))
End Sub

子测试（）
作为对象的Dim Dic，i%
设置Dic=CreateObject（“Scripting.Dictionary”）
Dic.comparemode=vbTextCompare
数到20
i=工作表函数.randbween（1,37）
如果不存在Dic（i），则Dic添加i，单元格（i，“A”）
温德
MsgBox连接（Dic.Items，Chr（13））
端接头

测试：

---

---

你非常可爱，当然现在它工作得非常完美。非常感谢。