excel按班级分组，每组按百分比随机抽取数据，两次抽取不重复

需求

有一张学生班级信息表，需要按每个班的人数比例，每次随机抽取6%的学生，且第二次抽取与第一次抽取的结果不能重复：

信息表如下图：

一、实现方案

使用VB编程，在开发工具，VB编辑器中插入一个模块，然后粘贴下面的代码并运行即可实现，按照A列分组并抽取6%的学生按C列区分存入sheet2

二、代码详情

Sub Getdates()
    brr = Sheet2.Range("A1:D" & Sheet2.Cells(Rows.Count, "A").End(3).Row)
    arr = Sheet1.Range("A1:C" & Sheet1.Cells(Rows.Count, "A").End(3).Row)
    Dim t As Date
    t = Now()
    ReDim br(1 To UBound(arr), 1 To 4)
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    For I = 2 To UBound(brr)
        d1(brr(I, 4)) = ""
    Next
    For I = 2 To UBound(arr)
        d2(arr(I, 1)) = d2(arr(I, 1)) + 1
        If Not d1.exists(arr(I, 3)) Then
            d(arr(I, 1)) = d(arr(I, 1)) & "," & I
        End If
    Next
    ar = d.items
    cr = d.keys
    d.RemoveAll
    d1.RemoveAll
    For I = 0 To UBound(ar)
        arT = Split(Mid(ar(I), 2), ",")
         6%后四舍五入
        imax = Rand(d2(cr(I)) * 0.06)
        If imax = o Then
        imax = 1
        End If
        If UBound(arT) > 0 Then
            Do While x < imax
                num = WorksheetFunction.RandBetween(0, UBound(arT))
                If Not d.exists(num) Then
                   d(num) = ""
                   x = x + 1
                   k = k + 1
                   br(k, 1) = t
                   br(k, 2) = arr(arT(num), 1)
                   br(k, 3) = arr(arT(num), 2)
                   br(k, 4) = arr(arT(num), 3)
                End If
                If d.Count = UBound(arT) + 1 Then
                Exit Do
                End If
            Loop
            d.RemoveAll
            x = 0
            imax = 0
        Else
            k = k + 1
            br(k, 1) = t
            br(k, 2) = arr(arT(0), 1)
            br(k, 3) = arr(arT(0), 2)
            br(k, 4) = arr(arT(0), 3)
        End If
    Next
    If k > 0 Then
    Sheet2.Range("A" & Sheet2.Cells(Rows.Count, "A").End(3).Row + 1).Resize(k, 4) = br
    Erase br
    End If
    Erase arr
    Erase brr
    Set d2 = Nothing
    Set d = Nothing
    Set d1 = Nothing
End Sub

注意事项

VB编辑器，office任意版本均有；但WPS则需要专业版才有；或者是免费版但安装了VB编辑器插件