[已解决]请大师帮助调试一下问题

cqfdrslyh

请大师帮助给调式一下
目前存在的问题有：
1.监考安排下有一个数字，即是就需要安排的人数，现在填0，本应该空，但现在仍在安排。
2.能不能在监考安排下面，我人工自己填写几个，然后再按需要安排的人数补充另外的几个。
3.天数计算能不能用公式计算出来，如果不平均自动重新再次按排一次，直到大约平均。

感谢大师的帮助。

最佳答案

月排行榜 / 总排行榜

林木水

2022-1-11 17:16

cqfdrslyh 发表于 2022-1-11 14:27
感谢！现在发现同一日工作有重复，比如要么领队，要么校外监考，要么校内监考，同一日只能一件工作

1. Option Explicit
   
2. Sub demo()
   
3. On Error Resume Next
   
4. Dim arr, h, i As Integer
   
5. h = Sheet1.Range("a65536").End(xlUp).Row
   
6. arr = Sheet1.Range("a2:b" & h)
   
7. If h = 1 Then End
   
8. Union(Sheet1.Range("h3:j" & h), Sheet1.Range("m3:m" & h), Sheet1.Range("p3:p" & h)) = ""
   
9. Call 固定组
   
10. Dim m1 As Integer, m2 As Integer, k As Integer, x As Integer, y As Integer
    
11. Dim d As New Dictionary
    
12.     For i = 10 To 18
    
13.         k = k + 1
    
14.         m1 = Sheet1.Cells(65536, i - 1).End(xlUp).Row
    
15.         m2 = Sheet1.Cells(65536, i).End(xlUp).Row
    
16.         If k = 1 Then
    
17.             Call 排序天数
    
18.             For x = 2 To h
    
19.                 d(Sheet1.Cells(x, 1).Value) = ""
    
20.             Next x
    
21.             For x = 3 To m2
    
22.                 d.Remove Sheet1.Cells(x, i).Value
    
23.             Next x
    
24.         ElseIf k = 2 Then
    
25.             If Sheet1.Cells(2, i).Value = "" Or Sheet1.Cells(2, i).Value = 0 Then
    
26.                 Sheet1.Cells(3, i).Resize(h) = ""
    
27.             ElseIf m2 - 2 > Sheet1.Cells(2, i).Value Then
    
28.                 MsgBox Sheet1.Cells(1, i).Value & "的人数超出，请减少"
    
29.                 Sheet1.Range("a2:b" & h) = arr
    
30.                 End
    
31.             ElseIf m2 - 2 = Sheet1.Cells(2, i).Value Then
    
32.             ElseIf m2 - 2 < Sheet1.Cells(2, i).Value Then
    
33.                 For x = 3 To m2
    
34.                     d.Remove Sheet1.Cells(x, i).Value
    
35.                 Next x
    
36.                 Sheet1.Cells(x, i).Resize(Sheet1.Cells(2, i).Value - (m2 - 2)) = Application.Transpose(d.Keys)
    
37.             End If
    
38.         Else
    
39.             'k=3
    
40.             If Sheet1.Cells(2, i).Value = "" Or Sheet1.Cells(2, i).Value = 0 Then
    
41.                 Sheet1.Cells(3, i).Resize(h) = ""
    
42.             ElseIf m2 - 2 > Sheet1.Cells(2, i).Value Then
    
43.                 MsgBox Sheet1.Cells(1, i).Value & "的人数超出，请减少"
    
44.                 Sheet1.Range("a2:b" & h) = arr
    
45.                 End
    
46.             ElseIf m2 - 2 = Sheet1.Cells(2, i).Value Then
    
47.             ElseIf m2 - 2 < Sheet1.Cells(2, i).Value Then
    
48.                 For x = 3 To m1
    
49.                     d.Remove Sheet1.Cells(x, i - 1).Value
    
50.                 Next x
    
51.                 For x = 3 To m2
    
52.                     d.Remove Sheet1.Cells(x, i).Value
    
53.                 Next x
    
54.                 Sheet1.Cells(x, i).Resize(Sheet1.Cells(2, i).Value - (m2 - 2)) = Application.Transpose(d.Keys)
    
55.             End If
    
56.             k = 0
    
57.         End If
    
58.     Next i
    
59. Sheet1.Range("a2:b" & h) = arr
    
60. End Sub
    
61. Sub 固定组()
    
62. Dim d1 As Object
    
63. Dim d2 As Object
    
64. Dim d3 As Object
    
65. Dim d4 As Object
    
66. Dim d5 As Object
    
67. Dim d6 As Object
    
68. Dim i As Integer, arr
    
69. arr = Sheet1.Range("a2:b" & Sheet1.Range("b65536").End(xlUp).Row)
    
70. If Sheet1.Range("b65536").End(xlUp).Row = 1 Then End
    
71. Set d1 = CreateObject("scripting.dictionary")
    
72. Set d2 = CreateObject("scripting.dictionary")
    
73. Set d3 = CreateObject("scripting.dictionary")
    
74. Set d4 = CreateObject("scripting.dictionary")
    
75. Set d5 = CreateObject("scripting.dictionary")
    
76. Set d6 = CreateObject("scripting.dictionary")
    
77. Dim brr, f, x
    
78. brr = Array("考务组", "纪检组", "24日领队", "25日领队", "26日领队", "无")
    
79.     For i = 1 To UBound(arr, 1)
    
80.         x = Application.Match(arr(i, 2), brr, 0)
    
81.         If x = 1 Then
    
82.             d1(arr(i, 1)) = arr(i, 2)
    
83.         ElseIf x = 2 Then
    
84.             d2(arr(i, 1)) = arr(i, 2)
    
85.         ElseIf x = 3 Then
    
86.             d3(arr(i, 1)) = arr(i, 2)
    
87.         ElseIf x = 4 Then
    
88.             d4(arr(i, 1)) = arr(i, 2)
    
89.         ElseIf x = 5 Then
    
90.             d5(arr(i, 1)) = arr(i, 2)
    
91.         Else
    
92.             d6(arr(i, 1)) = arr(i, 2)
    
93.         End If
    
94.     Next i
    
95.     Sheet1.Range("h3").Resize(d1.Count) = Application.Transpose(d1.Keys)
    
96.     Sheet1.Range("i3").Resize(d2.Count) = Application.Transpose(d2.Keys)
    
97.     Sheet1.Range("j3").Resize(d3.Count) = Application.Transpose(d3.Keys)
    
98.     Sheet1.Range("m3").Resize(d4.Count) = Application.Transpose(d4.Keys)
    
99.     Sheet1.Range("P3").Resize(d5.Count) = Application.Transpose(d5.Keys)
    
100.     d1.RemoveAll: d2.RemoveAll: d3.RemoveAll: d4.RemoveAll: d5.RemoveAll: d6.RemoveAll
     
101. End Sub
     
102. Sub 排序天数()
     
103. Dim arr, h
     
104. h = Sheet1.Range("a65536").End(xlUp).Row
     
105. arr = Sheet1.Range("a2:b" & h)
     
106. If h = 1 Then End
     
107. Sheet1.Range("a1:c" & h).Sort Range("c1")
     
108. End Sub
     
109. 
     

复制代码

你早一些把需求说清楚就不会有这些问题了。看下是否ok了

跳转到最佳答案楼层

林木水

1. <div class="blockcode"><blockquote>Sub demo()
   
2. Dim arr, h, i As Integer, hrr, crr
   
3. h = Sheet1.Range("a65536").End(xlUp).Row
   
4. arr = Sheet1.Range("a2:b" & h)
   
5. If h = 1 Then End
   
6. Sheet1.Range("h3:r65536") = ""
   
7. Call 固定组
   
8. hrr = Sheet1.Range("g1:r2")
   
9. For i = 1 To UBound(hrr, 2)
   
10.     If right(hrr(1, i), 1) = "日" And hrr(2, i) <> 0 And hrr(2, i) <> "" Then
    
11.         Call 排序天数
    
12.         Sheet1.Range("f3").Offset(0, i).Resize(hrr(2, i), 1) = Sheet1.Range("a2").Resize(hrr(2, i), 1).Value
    
13.     End If
    
14. Next i
    
15. Sheet1.Range("a2:b" & h) = arr
    
16. End Sub
    
17. Sub 固定组()
    
18. Dim d1 As Object
    
19. Dim d2 As Object
    
20. Dim d3 As Object
    
21. Dim d4 As Object
    
22. Dim d5 As Object
    
23. Dim d6 As Object
    
24. Dim i As Integer, arr
    
25. arr = Sheet1.Range("a2:b" & Sheet1.Range("b65536").End(xlUp).Row)
    
26. If Sheet1.Range("b65536").End(xlUp).Row = 1 Then End
    
27. Set d1 = CreateObject("scripting.dictionary")
    
28. Set d2 = CreateObject("scripting.dictionary")
    
29. Set d3 = CreateObject("scripting.dictionary")
    
30. Set d4 = CreateObject("scripting.dictionary")
    
31. Set d5 = CreateObject("scripting.dictionary")
    
32. Set d6 = CreateObject("scripting.dictionary")
    
33. Dim brr, f, x
    
34. brr = Array("考务组", "纪检组", "24日领队", "25日领队", "26日领队", "无")
    
35.     For i = 1 To UBound(arr, 1)
    
36.         x = Application.Match(arr(i, 2), brr, 0)
    
37.         If x = 1 Then
    
38.             d1(arr(i, 1)) = arr(i, 2)
    
39.         ElseIf x = 2 Then
    
40.             d2(arr(i, 1)) = arr(i, 2)
    
41.         ElseIf x = 3 Then
    
42.             d3(arr(i, 1)) = arr(i, 2)
    
43.         ElseIf x = 4 Then
    
44.             d4(arr(i, 1)) = arr(i, 2)
    
45.         ElseIf x = 5 Then
    
46.             d5(arr(i, 1)) = arr(i, 2)
    
47.         Else
    
48.             d6(arr(i, 1)) = arr(i, 2)
    
49.         End If
    
50.     Next i
    
51.     Sheet1.Range("h3").Resize(d1.Count) = Application.Transpose(d1.keys)
    
52.     Sheet1.Range("i3").Resize(d2.Count) = Application.Transpose(d2.keys)
    
53.     Sheet1.Range("j3").Resize(d3.Count) = Application.Transpose(d3.keys)
    
54.     Sheet1.Range("m3").Resize(d4.Count) = Application.Transpose(d4.keys)
    
55.     Sheet1.Range("P3").Resize(d5.Count) = Application.Transpose(d5.keys)
    
56.     d1.RemoveAll: d2.RemoveAll: d3.RemoveAll: d4.RemoveAll: d5.RemoveAll: d6.RemoveAll
    
57. End Sub
    
58. Sub 排序天数()
    
59. Dim arr, h
    
60. h = Sheet1.Range("a65536").End(xlUp).Row
    
61. arr = Sheet1.Range("a2:b" & h)
    
62. If h = 1 Then End
    
63. Sheet1.Range("a1:c" & h).Sort Range("c1")
    
64. End Sub
    

复制代码

思路：
1.其实你要想每个人的时效接近平均，那么就可以根据计算每个人的时效合计，再排序升序，下次从前面那些人里面抓名字就可以了
2.首先，添加辅助宏，字典抓出来固定组："考务组", "纪检组", "24日领队", "25日领队", "26日领队", "无"
3.添加辅助宏，升序排序天数，当然提前把原来的名字跟组别存入数组中，最后再赋值到单元格
4.黄色单元格手动填写数字的地方，根据right取一个字符结果为“日”，此为唯一性，所以可以作为if条件判断，再加一个值不等于0或者空
5.最后运行demo
以上，可以试试效果是否ok？

cqfdrslyh

林木水 发表于 2022-1-10 16:36
思路：
1.其实你要想每个人的时效接近平均，那么就可以根据计算每个人的时效合计，再排序升序，下次从前 ...

感谢你及时帮助！
问题1和3解决了，
问题2：如果在监考下我人工添加部分名字，能不能根据上面的黄色数据自动补充完整呢？

林木水

cqfdrslyh 发表于 2022-1-10 21:15
感谢你及时帮助！
问题1和3解决了，
问题2：如果在监考下我人工添加部分名字，能不能根据上面的黄色数 ...

理论上是可以得，实际上你表达得问题我并没有听懂，能举例说明吗
是G列根据上面填写一个数字，自动填充多少个姓名吗？
比如24号监考：你填写数字10
先手动输入了2个名字，再用代码补全剩下得8个，这样吗？

cqfdrslyh

林木水 发表于 2022-1-10 21:20
理论上是可以得，实际上你表达得问题我并没有听懂，能举例说明吗
是G列根据上面填写一个数字，自动填充 ...

对，就是这个意思。感谢

林木水

cqfdrslyh 发表于 2022-1-11 10:33
对，就是这个意思。感谢

1. Sub demo()
   
2. Dim arr, h, i As Integer, hrr, crr
   
3. h = Sheet1.Range("a65536").End(xlUp).Row
   
4. arr = Sheet1.Range("a2:b" & h)
   
5. If h = 1 Then End
   
6. Union(Sheet1.Range("h3:j" & h), Sheet1.Range("m3:m" & h), Sheet1.Range("p3:p" & h)) = ""
   
7. Dim x As Integer
   
8. Call 固定组
   
9. hrr = Sheet1.Range("g1:r2")
   
10. For i = 1 To UBound(hrr, 2)
    
11.     If right(hrr(1, i), 1) = "日" And hrr(2, i) <> 0 And hrr(2, i) <> "" Then
    
12.         Call 排序天数
    
13.         x = hrr(2, i) - Application.WorksheetFunction.CountA(Sheet1.Range("F3").Offset(0, i).Resize(h, 1))
    
14.         If x <= 0 Then
    
15.             Sheet1.Range("F3").Offset(hrr(2, i), i).Resize(h, 1) = ""
    
16.         Else
    
17.             Sheet1.Range("f2").Offset(hrr(2, i), i).Resize(x, 1) = Sheet1.Range("a2").Resize(x, 1).Value
    
18.         End If
    
19.     End If
    
20. Next i
    
21. Sheet1.Range("a2:b" & h) = arr
    
22. End Sub
    
23. Sub 固定组()
    
24. Dim d1 As Object
    
25. Dim d2 As Object
    
26. Dim d3 As Object
    
27. Dim d4 As Object
    
28. Dim d5 As Object
    
29. Dim d6 As Object
    
30. Dim i As Integer, arr
    
31. arr = Sheet1.Range("a2:b" & Sheet1.Range("b65536").End(xlUp).Row)
    
32. If Sheet1.Range("b65536").End(xlUp).Row = 1 Then End
    
33. Set d1 = CreateObject("scripting.dictionary")
    
34. Set d2 = CreateObject("scripting.dictionary")
    
35. Set d3 = CreateObject("scripting.dictionary")
    
36. Set d4 = CreateObject("scripting.dictionary")
    
37. Set d5 = CreateObject("scripting.dictionary")
    
38. Set d6 = CreateObject("scripting.dictionary")
    
39. Dim brr, f, x
    
40. brr = Array("考务组", "纪检组", "24日领队", "25日领队", "26日领队", "无")
    
41.     For i = 1 To UBound(arr, 1)
    
42.         x = Application.Match(arr(i, 2), brr, 0)
    
43.         If x = 1 Then
    
44.             d1(arr(i, 1)) = arr(i, 2)
    
45.         ElseIf x = 2 Then
    
46.             d2(arr(i, 1)) = arr(i, 2)
    
47.         ElseIf x = 3 Then
    
48.             d3(arr(i, 1)) = arr(i, 2)
    
49.         ElseIf x = 4 Then
    
50.             d4(arr(i, 1)) = arr(i, 2)
    
51.         ElseIf x = 5 Then
    
52.             d5(arr(i, 1)) = arr(i, 2)
    
53.         Else
    
54.             d6(arr(i, 1)) = arr(i, 2)
    
55.         End If
    
56.     Next i
    
57.     Sheet1.Range("h3").Resize(d1.Count) = Application.Transpose(d1.keys)
    
58.     Sheet1.Range("i3").Resize(d2.Count) = Application.Transpose(d2.keys)
    
59.     Sheet1.Range("j3").Resize(d3.Count) = Application.Transpose(d3.keys)
    
60.     Sheet1.Range("m3").Resize(d4.Count) = Application.Transpose(d4.keys)
    
61.     Sheet1.Range("P3").Resize(d5.Count) = Application.Transpose(d5.keys)
    
62.     d1.RemoveAll: d2.RemoveAll: d3.RemoveAll: d4.RemoveAll: d5.RemoveAll: d6.RemoveAll
    
63. End Sub
    
64. Sub 排序天数()
    
65. Dim arr, h
    
66. h = Sheet1.Range("a65536").End(xlUp).Row
    
67. arr = Sheet1.Range("a2:b" & h)
    
68. If h = 1 Then End
    
69. Sheet1.Range("a1:c" & h).Sort Range("c1")
    
70. End Sub
    

复制代码

试试？

cqfdrslyh

林木水 发表于 2022-1-11 10:59
试试？

感谢。我试了一下，上面的数据与下面的名字差1，比如14，下面的名字只有13个。

林木水

cqfdrslyh 发表于 2022-1-11 11:28
感谢。我试了一下，上面的数据与下面的名字差1，比如14，下面的名字只有13个。

1. Sub demo()
   
2. Dim arr, h, i As Integer, hrr, crr
   
3. h = Sheet1.Range("a65536").End(xlUp).Row
   
4. arr = Sheet1.Range("a2:b" & h)
   
5. If h = 1 Then End
   
6. Union(Sheet1.Range("h3:j" & h), Sheet1.Range("m3:m" & h), Sheet1.Range("p3:p" & h)) = ""
   
7. Dim x As Integer
   
8. Call 固定组
   
9. hrr = Sheet1.Range("g1:r2")
   
10. For i = 1 To UBound(hrr, 2)
    
11.     If right(hrr(1, i), 1) = "日" And hrr(2, i) <> 0 And hrr(2, i) <> "" Then
    
12.         Call 排序天数
    
13.         x = hrr(2, i) - Application.WorksheetFunction.CountA(Sheet1.Range("F3").Offset(0, i).Resize(h, 1))
    
14.         If x <= 0 Then
    
15.             Sheet1.Range("F3").Offset(hrr(2, i), i).Resize(h, 1) = ""
    
16.         Else
    
17.             Sheet1.Range("f2").Offset(Application.WorksheetFunction.CountA(Sheet1.Range("F3").Offset(0, i).Resize(h, 1)) + 1, i).Resize(x, 1) = Sheet1.Range("a2").Resize(x, 1).Value
    
18.         End If
    
19.     End If
    
20.     If right(hrr(1, i), 1) = "日" And (hrr(2, i) = 0 Or hrr(2, i) = "") Then
    
21.         Sheet1.Range("f3").Offset(0, i).Resize(h, 1) = ""
    
22.     End If
    
23. Next i
    
24. Sheet1.Range("a2:b" & h) = arr
    
25. End Sub
    
26. Sub 固定组()
    
27. Dim d1 As Object
    
28. Dim d2 As Object
    
29. Dim d3 As Object
    
30. Dim d4 As Object
    
31. Dim d5 As Object
    
32. Dim d6 As Object
    
33. Dim i As Integer, arr
    
34. arr = Sheet1.Range("a2:b" & Sheet1.Range("b65536").End(xlUp).Row)
    
35. If Sheet1.Range("b65536").End(xlUp).Row = 1 Then End
    
36. Set d1 = CreateObject("scripting.dictionary")
    
37. Set d2 = CreateObject("scripting.dictionary")
    
38. Set d3 = CreateObject("scripting.dictionary")
    
39. Set d4 = CreateObject("scripting.dictionary")
    
40. Set d5 = CreateObject("scripting.dictionary")
    
41. Set d6 = CreateObject("scripting.dictionary")
    
42. Dim brr, f, x
    
43. brr = Array("考务组", "纪检组", "24日领队", "25日领队", "26日领队", "无")
    
44.     For i = 1 To UBound(arr, 1)
    
45.         x = Application.Match(arr(i, 2), brr, 0)
    
46.         If x = 1 Then
    
47.             d1(arr(i, 1)) = arr(i, 2)
    
48.         ElseIf x = 2 Then
    
49.             d2(arr(i, 1)) = arr(i, 2)
    
50.         ElseIf x = 3 Then
    
51.             d3(arr(i, 1)) = arr(i, 2)
    
52.         ElseIf x = 4 Then
    
53.             d4(arr(i, 1)) = arr(i, 2)
    
54.         ElseIf x = 5 Then
    
55.             d5(arr(i, 1)) = arr(i, 2)
    
56.         Else
    
57.             d6(arr(i, 1)) = arr(i, 2)
    
58.         End If
    
59.     Next i
    
60.     Sheet1.Range("h3").Resize(d1.Count) = Application.Transpose(d1.keys)
    
61.     Sheet1.Range("i3").Resize(d2.Count) = Application.Transpose(d2.keys)
    
62.     Sheet1.Range("j3").Resize(d3.Count) = Application.Transpose(d3.keys)
    
63.     Sheet1.Range("m3").Resize(d4.Count) = Application.Transpose(d4.keys)
    
64.     Sheet1.Range("P3").Resize(d5.Count) = Application.Transpose(d5.keys)
    
65.     d1.RemoveAll: d2.RemoveAll: d3.RemoveAll: d4.RemoveAll: d5.RemoveAll: d6.RemoveAll
    
66. End Sub
    
67. Sub 排序天数()
    
68. Dim arr, h
    
69. h = Sheet1.Range("a65536").End(xlUp).Row
    
70. arr = Sheet1.Range("a2:b" & h)
    
71. If h = 1 Then End
    
72. Sheet1.Range("a1:c" & h).Sort Range("c1")
    
73. End Sub
    

复制代码

第17句代码改了一下，试一下！
另外添加了几行代码删除0个“”

cqfdrslyh

感谢！现在发现同一日工作有重复，比如要么领队，要么校外监考，要么校内监考，同一日只能一件工作

林木水

cqfdrslyh 发表于 2022-1-11 14:27
感谢！现在发现同一日工作有重复，比如要么领队，要么校外监考，要么校内监考，同一日只能一件工作

1. Option Explicit
   
2. Sub demo()
   
3. On Error Resume Next
   
4. Dim arr, h, i As Integer
   
5. h = Sheet1.Range("a65536").End(xlUp).Row
   
6. arr = Sheet1.Range("a2:b" & h)
   
7. If h = 1 Then End
   
8. Union(Sheet1.Range("h3:j" & h), Sheet1.Range("m3:m" & h), Sheet1.Range("p3:p" & h)) = ""
   
9. Call 固定组
   
10. Dim m1 As Integer, m2 As Integer, k As Integer, x As Integer, y As Integer
    
11. Dim d As New Dictionary
    
12.     For i = 10 To 18
    
13.         k = k + 1
    
14.         m1 = Sheet1.Cells(65536, i - 1).End(xlUp).Row
    
15.         m2 = Sheet1.Cells(65536, i).End(xlUp).Row
    
16.         If k = 1 Then
    
17.             Call 排序天数
    
18.             For x = 2 To h
    
19.                 d(Sheet1.Cells(x, 1).Value) = ""
    
20.             Next x
    
21.             For x = 3 To m2
    
22.                 d.Remove Sheet1.Cells(x, i).Value
    
23.             Next x
    
24.         ElseIf k = 2 Then
    
25.             If Sheet1.Cells(2, i).Value = "" Or Sheet1.Cells(2, i).Value = 0 Then
    
26.                 Sheet1.Cells(3, i).Resize(h) = ""
    
27.             ElseIf m2 - 2 > Sheet1.Cells(2, i).Value Then
    
28.                 MsgBox Sheet1.Cells(1, i).Value & "的人数超出，请减少"
    
29.                 Sheet1.Range("a2:b" & h) = arr
    
30.                 End
    
31.             ElseIf m2 - 2 = Sheet1.Cells(2, i).Value Then
    
32.             ElseIf m2 - 2 < Sheet1.Cells(2, i).Value Then
    
33.                 For x = 3 To m2
    
34.                     d.Remove Sheet1.Cells(x, i).Value
    
35.                 Next x
    
36.                 Sheet1.Cells(x, i).Resize(Sheet1.Cells(2, i).Value - (m2 - 2)) = Application.Transpose(d.Keys)
    
37.             End If
    
38.         Else
    
39.             'k=3
    
40.             If Sheet1.Cells(2, i).Value = "" Or Sheet1.Cells(2, i).Value = 0 Then
    
41.                 Sheet1.Cells(3, i).Resize(h) = ""
    
42.             ElseIf m2 - 2 > Sheet1.Cells(2, i).Value Then
    
43.                 MsgBox Sheet1.Cells(1, i).Value & "的人数超出，请减少"
    
44.                 Sheet1.Range("a2:b" & h) = arr
    
45.                 End
    
46.             ElseIf m2 - 2 = Sheet1.Cells(2, i).Value Then
    
47.             ElseIf m2 - 2 < Sheet1.Cells(2, i).Value Then
    
48.                 For x = 3 To m1
    
49.                     d.Remove Sheet1.Cells(x, i - 1).Value
    
50.                 Next x
    
51.                 For x = 3 To m2
    
52.                     d.Remove Sheet1.Cells(x, i).Value
    
53.                 Next x
    
54.                 Sheet1.Cells(x, i).Resize(Sheet1.Cells(2, i).Value - (m2 - 2)) = Application.Transpose(d.Keys)
    
55.             End If
    
56.             k = 0
    
57.         End If
    
58.     Next i
    
59. Sheet1.Range("a2:b" & h) = arr
    
60. End Sub
    
61. Sub 固定组()
    
62. Dim d1 As Object
    
63. Dim d2 As Object
    
64. Dim d3 As Object
    
65. Dim d4 As Object
    
66. Dim d5 As Object
    
67. Dim d6 As Object
    
68. Dim i As Integer, arr
    
69. arr = Sheet1.Range("a2:b" & Sheet1.Range("b65536").End(xlUp).Row)
    
70. If Sheet1.Range("b65536").End(xlUp).Row = 1 Then End
    
71. Set d1 = CreateObject("scripting.dictionary")
    
72. Set d2 = CreateObject("scripting.dictionary")
    
73. Set d3 = CreateObject("scripting.dictionary")
    
74. Set d4 = CreateObject("scripting.dictionary")
    
75. Set d5 = CreateObject("scripting.dictionary")
    
76. Set d6 = CreateObject("scripting.dictionary")
    
77. Dim brr, f, x
    
78. brr = Array("考务组", "纪检组", "24日领队", "25日领队", "26日领队", "无")
    
79.     For i = 1 To UBound(arr, 1)
    
80.         x = Application.Match(arr(i, 2), brr, 0)
    
81.         If x = 1 Then
    
82.             d1(arr(i, 1)) = arr(i, 2)
    
83.         ElseIf x = 2 Then
    
84.             d2(arr(i, 1)) = arr(i, 2)
    
85.         ElseIf x = 3 Then
    
86.             d3(arr(i, 1)) = arr(i, 2)
    
87.         ElseIf x = 4 Then
    
88.             d4(arr(i, 1)) = arr(i, 2)
    
89.         ElseIf x = 5 Then
    
90.             d5(arr(i, 1)) = arr(i, 2)
    
91.         Else
    
92.             d6(arr(i, 1)) = arr(i, 2)
    
93.         End If
    
94.     Next i
    
95.     Sheet1.Range("h3").Resize(d1.Count) = Application.Transpose(d1.Keys)
    
96.     Sheet1.Range("i3").Resize(d2.Count) = Application.Transpose(d2.Keys)
    
97.     Sheet1.Range("j3").Resize(d3.Count) = Application.Transpose(d3.Keys)
    
98.     Sheet1.Range("m3").Resize(d4.Count) = Application.Transpose(d4.Keys)
    
99.     Sheet1.Range("P3").Resize(d5.Count) = Application.Transpose(d5.Keys)
    
100.     d1.RemoveAll: d2.RemoveAll: d3.RemoveAll: d4.RemoveAll: d5.RemoveAll: d6.RemoveAll
     
101. End Sub
     
102. Sub 排序天数()
     
103. Dim arr, h
     
104. h = Sheet1.Range("a65536").End(xlUp).Row
     
105. arr = Sheet1.Range("a2:b" & h)
     
106. If h = 1 Then End
     
107. Sheet1.Range("a1:c" & h).Sort Range("c1")
     
108. End Sub
     
109. 
     

复制代码

你早一些把需求说清楚就不会有这些问题了。看下是否ok了