考场抽签，随机排序

戎马书生222

不同颜色的考场在不同的教学楼，只能在同颜色里随机排序。
下面是参考代码。求助高手给修改一下。
Sub test()
    r = Application.CountA(Range("a:a"))
    r1 = [a65536].End(3).Row
    Range("c:c").ClearContents
    Set d = CreateObject("Scripting.Dictionary") '字典
    For i = 1 To 100
        s = Int(Rnd * r + 1)
        d(s) = ""
        If d.Count = r Then Exit For
    Next i
    k = d.keys
    For j = 1 To r1
        If Cells(j, 1) <> "" Then
        n = n + 1
        x = k(n - 1)
        Cells(j, 3) = k(n - 1)
        End If
    Next j
    ThisWorkbook.Save
End Sub

shiruiqiang

戎马书生222

或者用下面这段代码，从论坛里复制来的，忘了是哪位朋友的了。
Sub main()
Dim Ar, I&, Br(), K&
    Ar = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row).Value
    For I = 1 To UBound(Ar)
        If Ar(I, 1) <> "" Then
            K = K + 1
            ReDim Preserve Br(1 To K)
            Br(K) = Ar(I, 1)
        End If
    Next I
   
    Call GetRnd(Br, 1, K, K)
    K = 0
    For I = 1 To UBound(Ar)
         If Ar(I, 1) <> "" Then
            K = K + 1
            Ar(I, 1) = Br(K)
        End If
    Next I
    Range("b1").Resize(UBound(Ar), 1) = Ar
End Sub
Sub GetRnd(Brr, a, b, N&) '香川
Dim L&, I&, R&, T
    Randomize
    L = LBound(Brr)
    For I = L To N + L - 1 '一維数組洗牌
     R = Int(Rnd() * (b - a + 1 - (I - L))) + a + (I - L)
        T = Brr(R): Brr(R) = Brr(a + (I - L)): Brr(I) = T '一維
  Next
End Sub

gwjkkkkk

Option Explicit
Sub test2()
    Dim ar, br(), i&, j&, r&
   
    Application.ScreenUpdating = False
   
    With [A1].CurrentRegion
        ar = .Value
        For j = 1 To UBound(ar, 2) Step 3
            Erase br: r = 0
            For i = 3 To UBound(ar)
                If Len(ar(i, j)) Then
                    r = r + 1
                    ReDim Preserve br(1 To r)
                    br(r) = ar(i, j)
                End If
            Next i
            arrGetRnd1 br
            For i = 1 To UBound(br)
                ar(i + 2, j + 1) = br(i)
            Next i
        Next j
        .Value = ar
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function arrGetRnd1(ByRef ar)
    Dim xNum&, i&, n&, vTemp
    Randomize
    n = UBound(ar)
    For i = 1 To UBound(ar)
        xNum = Int((n - i + 1) * Rnd() + i)
        vTemp = ar(xNum): ar(xNum) = ar(i): ar(i) = vTemp
    Next
End Function

gwjkkkkk

请参考。。。

戎马书生222

下面代码是从论坛的网友复制来的，可以参考
Sub main()
Dim Ar, I&, Br(), K&
    Ar = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row).Value
    For I = 1 To UBound(Ar)
        If Ar(I, 1) <> "" Then
            K = K + 1
            ReDim Preserve Br(1 To K)
            Br(K) = Ar(I, 1)
        End If
    Next I
   
    Call GetRnd(Br, 1, K, K)
    K = 0
    For I = 1 To UBound(Ar)
         If Ar(I, 1) <> "" Then
            K = K + 1
            Ar(I, 1) = Br(K)
        End If
    Next I
    Range("b1").Resize(UBound(Ar), 1) = Ar
End Sub
Sub GetRnd(Brr, a, b, N&) '香川
Dim L&, I&, R&, T
    Randomize
    L = LBound(Brr)
    For I = L To N + L - 1 '一維数組洗牌
     R = Int(Rnd() * (b - a + 1 - (I - L))) + a + (I - L)
        T = Brr(R): Brr(R) = Brr(a + (I - L)): Brr(I) = T '一維
  Next
End Sub

LIUZHU

参与下，效果

LIUZHU

JS代码

1. function 考场抽签(){
   
2.         ["a3","d3","g3"].forEach(rg=>{
   
3.                 let res=[], arr=Range(Range(rg),Range(rg).End(xlDown)).Value2;
   
4.                 while(arr.length!=0) res.push(arr.splice(Math.floor(Math.random()*arr.length),1)[0]);
   
5.                 Range(rg).Offset(0,1).Resize(res.length,res[0].length).Value2=res;
   
6.         });
   
7. }

复制代码

LIUZHU

附件，WPS测试有效

戎马书生222

LIUZHU 发表于 2024-6-13 15:21
附件，WPS测试有效

感谢。。。。。。。。。。。。