|
|
由于我自己思维方式的问题，实在看不懂上面各位高手的代码（实际是天太热静不下心来），只好自己写了。
对于这个问题，我第一感觉就是先把原始数据进行重组，使之同校的学生处于同一行中（附件表3的效果），然后按列进行每6人一组的选取，但是，这时存在两个问题，一个是随机的问题，二个是按列选取时最后一组会有重复。
第一个问题的解决是听取了版主的意见，先生成随机不重复的数组，然后把原始数据打乱。
第二个问题费了很长时间，最后增加了一个数组存放学校名称，用字典进行判断。
最终效果见附件表2。
本来认为近百行的代码会很慢，没想到却飞快，看来还是用数组解决问题好，怪不得群子那么喜欢用数组。
Sub test2()
Dim ar1, ar2, xx(), cr(), br(), xb, r&, i&, j&, k&, x&, n&, m&, mc&, s, d, d1, t
t = Timer
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ar1 = Sheet1.[a1].CurrentRegion
ar2 = ar1
r = UBound(ar1)
ReDim cr(2 To r)
For i = 2 To r
cr(i) = i
Next i
For i = 2 To r
n = Int(Rnd() * (r - i + 1)) + i
s = cr(i)
cr(i) = cr(n)
cr(n) = s
Next i
For i = 2 To r
For j = 1 To 4
ar2(i, j) = ar1(cr(i), j)
Next j
Next i
xb = Array("男", "女")
ReDim br(1 To r, 1 To 8)
For k = 0 To 1
n = 0
ReDim ar1(1 To r, 1 To r)
ReDim xx(1 To r, 1 To r)
ReDim cr(1 To r)
For i = 2 To r
s = ar2(i, 3)
If ar2(i, 4) = xb(k) Then
If d.exists(s) = 0 Then
n = n + 1
d(s) = n
ar1(n, 1) = s & ar2(i, 2)
xx(n, 1) = s
cr(n) = 1
Else
cr(d(s)) = cr(d(s)) + 1
ar1(d(s), cr(d(s))) = s & ar2(i, 2)
xx(d(s), cr(d(s))) = s
If mc < cr(d(s)) Then mc = cr(d(s))
End If
End If
Next i
d.RemoveAll
For j = 1 To mc
For i = 1 To n
If ar1(i, j) <> "" Then
If d.Count = 6 Or d1.exists(xx(i, j)) Then
m = m + 1
s = d.keys
br(m, 1) = "宿舍" & m
br(m, 2) = xb(k)
For x = 0 To UBound(s)
br(m, x + 3) = s(x)
Next x
d.RemoveAll
d1.RemoveAll
End If
d(ar1(i, j)) = ""
d1(xx(i, j)) = ""
End If
Next i
Next j
If d.Count Then
m = m + 1
s = d.keys
br(m, 1) = "宿舍" & m
br(m, 2) = xb(k)
For x = 0 To UBound(s)
br(m, x + 3) = s(x)
Next x
d.RemoveAll
d1.RemoveAll
End If
Next k
Sheet2.[a1].Resize(m, 8) = br
MsgBox Format(Timer - t, "0.000")
End Sub
|
|
楼主: fanchunke1991
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2012-7-20 23:25
