提取相关数据并随机分组

一指禅62

    制作一个小程序时，写了一段随机分组的代码，后被优化代码替代。觉得丢了可惜，发在这儿备自己急用。

1. Option Explicit
   
2. 
   
3. Public Sub 计算机分组()
   
4.     Dim i As Long, j As Integer, SQL$, n As Long
   
5.     Sheet8.Range("A3:H65536").ClearContents
   
6.     Dim 年级$: 年级 = Sheet8.Range("J2")
   
7.     If 年级 = "" Then Exit Sub
   
8.     Rem 提取参加这个比赛组的运动员信息
   
9.     Dim Rs As Object
   
10.     Set Rs = CreateObject("Adodb.Recordset")
    
11.     SQL = "select 姓名,班级 from [报名表$] where 班级 like '" & Left(年级, 1) & "%' and 项目编码 like '%A07%'"
    
12.     Rs.Open SQL, cnn, 1, 3
    
13.     Sheet8.Range("A3").CopyFromRecordset Rs
    
14.     Rs.MoveFirst
    
15.     If Rs.RecordCount > 0 Then
    
16.         ReDim temp(1 To 2, 1 To Rs.RecordCount) '存放到数组
    
17.         For i = 0 To Rs.RecordCount - 1
    
18.             temp(1, i + 1) = Rs!姓名
    
19.             temp(2, i + 1) = Rs!班级
    
20.             Rs.MoveNext
    
21.         Next
    
22.         Rem 先对选手无序排列
    
23.         Dim crr(1 To 2), Index As Integer
    
24.         For i = 1 To Rs.RecordCount
    
25.             Randomize
    
26.             Index = Int(Rnd * Rs.RecordCount) + 1
    
27.             crr(1) = temp(1, i): temp(1, i) = temp(1, Index)
    
28.             crr(2) = temp(2, i): temp(2, i) = temp(2, Index)
    
29.             temp(1, Index) = crr(1)
    
30.             temp(2, Index) = crr(2)
    
31.         Next
    
32.         Sheet8.Range("D3").Resize(UBound(temp, 2), UBound(temp)) = WorksheetFunction.Transpose(temp)
    
33.         Rem 接力赛按班级排列
    
34.         Dim m%: m = 1
    
35.         For i = 1 To UBound(temp, 2)
    
36.             For j = i + 1 To UBound(temp, 2)
    
37.                 If temp(2, i) = temp(2, j) Then
    
38.                     m = m + 1: i = m
    
39.                     crr(1) = temp(1, j): crr(2) = temp(2, j)
    
40.                     temp(1, j) = temp(1, i): temp(2, j) = temp(2, i)
    
41.                     temp(1, i) = crr(1): temp(2, i) = crr(2)
    
42.                 End If
    
43.             Next
    
44.             m = m + 1
    
45.         Next
    
46.         Sheet8.Range("G3").Resize(UBound(temp, 2), UBound(temp)) = WorksheetFunction.Transpose(temp)
    
47.     Else
    
48.         MsgBox 年级 & "没有该项目!"
    
49.     End If
    
50. End Sub
    
51. 
    
52. Public Function cnn() As Object
    
53.     Set cnn = CreateObject("adodb.connection")
    
54.     If Application.Version < 12 Then
    
55.         cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    
56.     Else
    
57.         cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    
58.     End If
    
59. End Function
    

复制代码

数组随机排序与分组.zip (55.2 KB, 下载次数: 47)

2015-12-14 12:32 上传

点击文件名下载附件

weiyingde

不错，值得收藏