分班调班（待调整名单超过数量显示下标越界）

hongzefm

1. Sub Main()
   
2. Dim SK$
   
3. Dim s_Name$, s_Class_N$, d_Score#, s_Class_O$
   
4. Dim arr
   
5. Dim n1%, n2%
   
6. Dim i
   
7. 
   
8. arr = Sheets("待调整名单").UsedRange
   
9. brr = Sheets("分班名单").UsedRange     '用数组提高运行速度
   
10. Set Dic = CreateObject("Scripting.Dictionary")
    
11. For i = 2 To UBound(arr)
    
12. brr = Sheets("分班名单").UsedRange     '用数组提高运行速度
    
13. 
    
14.     s_Name = arr(i, 1)
    
15.     d_Score = arr(i, 3)
    
16.     s_Class_O = arr(i, 4)
    
17.     s_Class_N = arr(i, 5)
    
18.     SK = s_Class_N & "/" & s_Name
    
19.     Dic(SK) = Dic.Count + 1            '记录,排除已交换数据
    
20.    
    
21.     If i = 20 Then
    
22. '    Stop
    
23.     End If
    
24.     n1 = Find_Original_Line(brr, s_Class_O, s_Name) '原记录行号
    
25.     n2 = Find_Swap_Line(brr, s_Class_N, d_Score)    '交换行号
    
26.     If n2 = 0 Then Exit Sub
    
27.     Call Swap_Line(brr, n1, n2)
    
28. Next i
    
29. Dic.RemoveAll: Set Dic = Nothing
    
30. MsgBox ("DONE")
    
31. End Sub

复制代码

gtbb2002

hongzefm 发表于 2018-8-26 21:02
问题出在，在交换的时候，，，分班名单的数组被交换过破坏了原现场，造成调班名单的人员，找不到了。n1的值 ...

原数据没有被修改过了，也不行的，待调整名单里，删掉一些不需要调整的也不行

gtbb2002

hongzefm 发表于 2018-8-26 21:40

Sub Swap_Line(arr, i1, i2)
Dim j
Dim tmp(1 To 3)
With Sheets("NEW")
For j = 1 To 3      '循环列
    tmp(j) = arr(i2, j)
    arr(i2, j) = arr(i1, j)
        .Cells(i2, j) = arr(i1, j)
        .Cells(i2, j).Interior.ColorIndex = 6
    arr(i1, j) = tmp(j)
        .Cells(i1, j) = tmp(j)
        .Cells(i1, j).Interior.ColorIndex = 6
Next j
End With
End Sub
实际上出现提示都是在这一段里面

gtbb2002

谁能帮我看下，还是不行，代码错误总是在如上图那段代码

gtbb2002

所有的错误都在13楼上下两句，哪位大师帮忙测试一下，谢谢了。等

hongzefm

gtbb2002 发表于 2018-8-26 23:54
所有的错误都在13楼上下两句，哪位大师帮忙测试一下，谢谢了。等

你看一下。

待调班(名单）.zip (29.15 KB, 下载次数: 13)

2018-8-27 07:40 上传

点击文件名下载附件

一把小刀闯天下

'"待调整名单"中有重名:132、282、307,,,

'因为使用姓名作匹配不得重名，所以做了重名检查

Option Explicit

Sub test()
  Dim arr, brr, i, j, k, pos, t, cnt, min, s
  s = "待调整名单"
  arr = Sheets(s).[a1].CurrentRegion.Offset(1).Value
  Call checkname(arr, 1, UBound(arr, 1) - 1, s) '检查重名
  If Len(s) Then MsgBox s: Exit Sub
  s = "分班名单"
  With Sheets(s)
    brr = .Range("a2:e" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
  End With
  Call checkname(brr, 1, UBound(brr, 1) - 1, s) '检查重名
  If Len(s) Then MsgBox s: Exit Sub
  For i = 1 To UBound(brr, 1) - 1: brr(i, 5) = vbNullString: Next
  Call dsort(brr, 1, UBound(brr, 1) - 1, 4) '班级排序
  pos = Array(4, 2, 3)
  For i = 0 To UBound(pos) - 1 '性别、成绩排序
    For j = 1 To UBound(brr, 1) - 1
      For k = j To UBound(brr, 1) - 1
        If brr(k, pos(i)) <> brr(k + 1, pos(i)) Then
          Call dsort(brr, j, k, pos(i + 1)): j = k: Exit For
        End If
  Next k, j, i
  For i = 1 To UBound(arr, 1) - 1
    For j = 1 To UBound(brr, 1) - 1
      If brr(j, 2) = arr(i, 2) And brr(j, 4) = arr(i, 5) Then '班级、性别相同
        ReDim mark(1 To UBound(brr, 1), 1 To 2): cnt = 0
        For k = j To UBound(brr, 1) - 1
          If brr(k, 5) <> "R" Then '当前位置未换过
            cnt = cnt + 1: mark(cnt, 2) = k
            mark(cnt, 1) = Abs(arr(i, 3) - brr(k, 3))
          End If
          If brr(k + 1, 2) <> arr(i, 2) Then Exit For   '性别不同退出
        Next
        If cnt = 0 Then MsgBox "未匹配成功：" & arr(i, 1): Exit Sub
        min = mark(1, 1): pos = mark(1, 2)
        For k = 1 To cnt '取分数最小偏差
          If min > mark(k, 1) Then min = mark(k, 1): pos = mark(k, 2)
        Next
        For k = 1 To UBound(brr, 1) - 1
          If brr(k, 1) = arr(i, 1) Then '姓名、分数对换
            t = brr(pos, 1): brr(pos, 1) = brr(k, 1): brr(k, 1) = t '姓名
            t = brr(pos, 3): brr(pos, 3) = brr(k, 3): brr(k, 3) = t '成绩
            brr(pos, 5) = "R": Exit For
          End If
        Next
        If k = UBound(brr, 1) Then MsgBox "分班名单中无此人" & arr(i, 1): Exit Sub
        Exit For
      End If
  Next j, i
  Call dsort(brr, 1, UBound(brr, 1) - 1, 5) '调换标志排序
  With Sheets("NEW").[a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(UBound(brr, 1) - 1, UBound(brr, 2)) = brr
  End With
End Sub

Function checkname(arr, first, last, s)
  Dim dic, i
  Set dic = CreateObject("scripting.dictionary")
  For i = first To last
    If dic.exists(arr(i, 1)) Then
      s = s & "有重名：" & arr(i, 1): Exit Function
    Else
      dic(arr(i, 1)) = vbNullString
    End If
  Next
  s = vbNullString
End Function

Function dsort(arr, first, last, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) < arr(j, key) Then
        For k = 1 To UBound(arr, 2)
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function

gtbb2002

因为前几天，急着给学生调班级，来不及就手工调班，也忙着开学管理学生，无瑕上网，到今天才看到老师的代码，确实非常感谢老师的辛勤付出，我调试。

gtbb2002

朱荣兴 发表于 2018-8-27 22:53
其实，可能楼主的思路就出问题了，换个思路，先把需要固定安排到某班的学生放到预分班名单里面，先对预分班 ...

非常感谢荣兴老师的提醒，的确是这样，本来思路也是这样，但是别人有现成的，想改改拿过用，这样比较麻烦老师，但是还是解决不了问题，就手工调整，但是还是出了很多问题，，最近又忙着学生在军训，所以没有看到荣兴老师的回复，对不起了，没有及时回复。现在我附上附件，希望老师抽空帮我看下这个附件，希望的今天能派上用场。