求编一个VBA代码能实现随意安排位置（32人）

bluexuemei

好问题，有点难度。

chxw68

1. Sub test()
   
2.   Dim d As New Dictionary
   
3.   Dim dd(1 To 4) As New Dictionary
   
4.   Dim r%, i%, c%, j%
   
5.   Dim arr, brr()
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("b4:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.Exists(arr(i, 2)) Then
    
11.         Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       d(arr(i, 2))(arr(i, 1)) = ""
    
14.     Next
    
15.   End With
    
16.   
    
17.   For Each aa In d.Keys
    
18.     crr = d(aa).Keys
    
19.     n = Int((UBound(crr) + 1) / 4)
    
20.     For j = 1 To n
    
21.       For k = 1 To 4
    
22.         dd(k)(crr((j - 1) * 4 + k - 1)) = aa
    
23.         d(aa).Remove (crr((j - 1) * 4 + k - 1))
    
24.       Next
    
25.     Next
    
26.   Next
    
27.   
    
28.   For Each aa In d.Keys
    
29.     If d(aa).Count = 0 Then
    
30.       d.Remove (aa)
    
31.     End If
    
32.   Next
    
33.   
    
34.   For Each aa In d.Keys
    
35.     crr = d(aa).Keys
    
36.     n = Int((UBound(crr) + 1) / 2)
    
37.     For j = 1 To n
    
38.       For k = 1 To 2
    
39.         If k = 1 Then
    
40.           If dd(1).Count < dd(2).Count Then
    
41.             dd(1)(crr((j - 1) * 2 + k - 1)) = aa
    
42.           Else
    
43.             dd(2)(crr((j - 1) * 2 + k - 1)) = aa
    
44.           End If
    
45.           d(aa).Remove (crr((j - 1) * 2 + k - 1))
    
46.         Else
    
47.           If dd(3).Count < dd(4).Count Then
    
48.             dd(3)(crr((j - 1) * 2 + k - 1)) = aa
    
49.           Else
    
50.             dd(4)(crr((j - 1) * 2 + k - 1)) = aa
    
51.           End If
    
52.           d(aa).Remove (crr((j - 1) * 2 + k - 1))
    
53.         End If
    
54.       Next
    
55.     Next
    
56.   Next
    
57.   For Each aa In d.Keys
    
58.     If d(aa).Count = 0 Then
    
59.       d.Remove (aa)
    
60.     End If
    
61.   Next
    
62.   For Each aa In d.Keys
    
63.     For Each bb In d(aa).Keys
    
64.       If dd(1).Count < 8 Then
    
65.         dd(1)(bb) = aa
    
66.       ElseIf dd(2).Count < 8 Then
    
67.         dd(2)(bb) = aa
    
68.       ElseIf dd(3).Count < 8 Then
    
69.         dd(3)(bb) = aa
    
70.       Else
    
71.         dd(4)(bb) = aa
    
72.       End If
    
73.     Next
    
74.   Next
    
75.   m = 4
    
76.   With Worksheets("sheet1")
    
77.     For i = 1 To 4
    
78.       r = .Cells(.Rows.Count, 8).End(xlUp).Row
    
79.       If r = 1 Then r = r + 2
    
80.       .Cells(r + 1, 7).Resize(dd(i).Count, 2) = Application.Transpose(Application.Transpose(Application.Transpose(Array(dd(i).Keys, dd(i).Items))))
    
81.     Next
    
82. End With
    
83. End Sub
    

复制代码

chxw68

参见附件，没有认真校对，请楼主测试。

chxw68

楼上的代码对每个小区域内数据没有随意安放，下面的代码对此问题进行了纠正。

1. Sub test()
   
2.   Dim d As Object
   
3.   Dim dd(1 To 4) As Object
   
4.   Dim r%, i%, c%, j%
   
5.   Dim arr, brr()
   
6.   Randomize Timer
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   For i = 1 To 4
   
9.     Set dd(i) = CreateObject("scripting.dictionary")
   
10.   Next
    
11.   With Worksheets("sheet1")
    
12.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.     arr = .Range("b4:c" & r)
    
14.     For i = 1 To UBound(arr)
    
15.       If Not d.Exists(arr(i, 2)) Then
    
16.         Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
17.       End If
    
18.       d(arr(i, 2))(arr(i, 1)) = ""
    
19.     Next
    
20.   End With
    
21.   
    
22.   For Each aa In d.Keys
    
23.     crr = d(aa).Keys
    
24.     n = Int((UBound(crr) + 1) / 4)
    
25.     For j = 1 To n
    
26.       For k = 1 To 4
    
27.         dd(k)(crr((j - 1) * 4 + k - 1)) = aa
    
28.         d(aa).Remove (crr((j - 1) * 4 + k - 1))
    
29.       Next
    
30.     Next
    
31.   Next
    
32.   
    
33.   For Each aa In d.Keys
    
34.     If d(aa).Count = 0 Then
    
35.       d.Remove (aa)
    
36.     End If
    
37.   Next
    
38.   
    
39.   For Each aa In d.Keys
    
40.     crr = d(aa).Keys
    
41.     n = Int((UBound(crr) + 1) / 2)
    
42.     For j = 1 To n
    
43.       For k = 1 To 2
    
44.         If k = 1 Then
    
45.           If dd(1).Count < dd(2).Count Then
    
46.             dd(1)(crr((j - 1) * 2 + k - 1)) = aa
    
47.           Else
    
48.             dd(2)(crr((j - 1) * 2 + k - 1)) = aa
    
49.           End If
    
50.           d(aa).Remove (crr((j - 1) * 2 + k - 1))
    
51.         Else
    
52.           If dd(3).Count < dd(4).Count Then
    
53.             dd(3)(crr((j - 1) * 2 + k - 1)) = aa
    
54.           Else
    
55.             dd(4)(crr((j - 1) * 2 + k - 1)) = aa
    
56.           End If
    
57.           d(aa).Remove (crr((j - 1) * 2 + k - 1))
    
58.         End If
    
59.       Next
    
60.     Next
    
61.   Next
    
62.   For Each aa In d.Keys
    
63.     If d(aa).Count = 0 Then
    
64.       d.Remove (aa)
    
65.     End If
    
66.   Next
    
67.   For Each aa In d.Keys
    
68.     For Each bb In d(aa).Keys
    
69.       If dd(1).Count < 8 Then
    
70.         dd(1)(bb) = aa
    
71.       ElseIf dd(2).Count < 8 Then
    
72.         dd(2)(bb) = aa
    
73.       ElseIf dd(3).Count < 8 Then
    
74.         dd(3)(bb) = aa
    
75.       Else
    
76.         dd(4)(bb) = aa
    
77.       End If
    
78.     Next
    
79.   Next
    
80.   m = 4
    
81.   With Worksheets("sheet1")
    
82.     .Columns("g:h").Clear
    
83.     For i = 1 To 4
    
84.       r = .Cells(.Rows.Count, 8).End(xlUp).Row
    
85.       If r = 1 Then r = r + 2
    
86.       .Cells(r + 1, 7).Resize(dd(i).Count, 2) = Application.Transpose(Application.Transpose(Application.Transpose(Array(dd(i).Keys, dd(i).Items))))
    
87.     Next
    
88.     r = .Cells(.Rows.Count, "g").End(xlUp).Row
    
89.     ReDim brr(1 To r - 3)
    
90.     For i = 1 To UBound(brr) Step 8
    
91.       For j = 1 To 8
    
92.         brr(i + j - 1) = (Int((i - 1) / 8) + 1) * 10 + Rnd()
    
93.       Next
    
94.     Next
    
95.     .Range("i4").Resize(UBound(brr), 1) = Application.Transpose(brr)
    
96.     .Range("g4:i" & r).Sort key1:=.Range("i4"), order1:=xlAscending, header:=xlNo
    
97.     .Columns("i:i").Clear
    
98. End With
    
99. End Sub
    

复制代码

chxw68

详见附件。

lmx3517

chxw68 发表于 2014-7-5 21:48
详见附件。

首先感谢这位朋友的帮助，您编写的程序非常好，我非常感谢您！！！在我测试中发现几个问题看看如何解决：1、能不能将排序后的姓名和单位放在E、F列。2、少于32人时就不能运行报错，我最多不超过32人。3、G1——H3之间区域不能打字，打上字就会被删除。我原来将E、F列空着是为了做分区图，方便各位版主和老师看，好理解我的意思。您看看如何修改。最终我要的结果见新附件。

cl63519

3、G1——H3之间区域不能打字，打上字就会被删除。


G1——H3究竟能不能打字？

lmx3517

cl63519 发表于 2014-7-6 08:34
3、G1——H3之间区域不能打字，打上字就会被删除。

能打上字，一点按钮就会被删除

cl63519

lmx3517 发表于 2014-7-6 08:52
能打上字，一点按钮就会被删除

你不需要保留字吗？

chxw68

第1、3个问题已经解决了，解决第2个问题还需要一点时间，这个问题确实有些难。