求个按计划筛选安排人员的代码

779846526

YZC51 发表于 2019-1-18 13:40
不知现有的教室第一节课能容纳多少人？

总课表中有啊

liangmutou01

该代码能实现所要之功能，在本机上一切OK，随机检查了几个班，没有问题。你可以试一下，希望能帮到你。
Sub kcap()
  Dim conn As Object, zfc As String, L As Integer
  Set conn = CreateObject("ADODB.Connection")
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Sheets("安排").Range("e2:g65536").ClearContents
  With Sheets("总课表")
    .Range(.Cells(7, "d"), .Cells(.Range("d65536").End(3).Row, .Range("cz7").End(xlToLeft).Column)).Copy
  End With
  Sheets.Add: ActiveSheet.Name = "linshi"
  [g1].PasteSpecial Transpose:=True
  conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
  For L = 1 To 20
    If Cells(2, 9) = "" Then Exit For
    Range("a65536").End(3).Offset(1, 0).CopyFromRecordset conn.Execute("select 名称,学生容量,课程,学生人数,教师,""第" & L & "节"" from [linshi$g1:k65536] where 教师 is not null;")
    Columns("i:k").Delete
  Next L
  For Each dyg In Range(Cells(2, 1), Cells(Range("a65536").End(3).Row, "a"))
    If dyg.Offset(0, 2) = "" Or dyg.Offset(0, 3) = "" Or dyg.Offset(0, 4) = "" Or dyg.Offset(0, 5) = "" Then GoTo aaa
    zfc = "update [安排$a1:g65536] set 教室=" & dyg.Value & ",教师=""" & dyg.Offset(0, 4) & """,节次=""" & dyg.Offset(0, 5) & """ where 课程=""" & dyg.Offset(0, 2) & """ and  学号 in(select top " & dyg.Offset(0, 3) & " 学号 from [安排$a1:g65536] where 课程=""" & dyg.Offset(0, 2) & """ and 教师 is null)"
    conn.Execute (zfc)
aaa:  Next dyg
  conn.Close: Set conn = Nothing
  Sheets("linshi").Delete
  Sheet4.Select
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

liangmutou01

一并把原文件发给你，这个程序不限课时，8节、9节都行，只要你总课表排出来了即可。

779846526

liangmutou01 发表于 2019-1-18 22:23
一并把原文件发给你，这个程序不限课时，8节、9节都行，只要你总课表排出来了即可。

谢谢您的回贴，你的结果不是我要的，我测试发现同一节课同一位学员安排了相同的节次，他没法在同一节次上上三科不同的课程啊

liangmutou01

779846526 发表于 2019-1-18 22:49
谢谢您的回贴，你的结果不是我要的，我测试发现同一节课同一位学员安排了相同的节次，他没法在同一节次上 ...

正在修改中，需要时间哈。

YZC51

liangmutou01 发表于 2019-1-20 13:18
正在修改中，需要时间哈。

感觉还应该有个学员选课表。
这样才能决定那个学员上哪门课？！

779846526

YZC51 发表于 2019-1-20 16:10
感觉还应该有个学员选课表。
这样才能决定那个学员上哪门课？！

学员选课表在安排表中的前4列啊

liangmutou01

这个问题真的有难度，希望能看到更佳的处理方式。
Sub kcap()
  Dim conn As Object, mh As Long
  Set conn = CreateObject("ADODB.Connection")
  Application.ScreenUpdating = False
  Sheets("安排").Select
  ActiveSheet.AutoFilterMode = False
  Rows.Hidden = False
  Range("e2:h65536").ClearContents
  安排总行 = Range("a65536").End(3).Row
  Range("z1:cc655").ClearContents
  With Sheets("总课表")
    .Range(.Cells(7, "d"), .Cells(.Range("d65536").End(3).Row, .Range("cz7").End(xlToLeft).Column)).Copy
  End With
  Range("ag1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
  conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
  For mh = 1 To 20
    If Cells(2, "ai") = "" Then Exit For
    Range("aa65536").End(3).Offset(1, 0).CopyFromRecordset conn.Execute("select 名称,学生容量,课程,学生人数,教师,""第" & mh & "节"" from [安排$ag1:ak65536] where 教师 is not null;")
    Columns("ai:ak").Delete
  Next mh
  课表总行 = Range("aa65536").End(3).Row
  Range("z1:af1") = Array("代码", "教室", "容量", "课程", "学生", "教师", "节次")
  Range("z2:z" & 课表总行).Formula = "=ROW()"
    For mh = 2 To 安排总行
      Range("e" & mh).CopyFromRecordset conn.Execute("select top 1 教室,教师,节次,代码 from [安排$z1:af1000] where 课程='" & Cells(mh, 4).Value & "' and 学生>0 and 节次 not in(select 节次 from [安排$a1:g10000] where 学号=" & Cells(mh, 1).Value & " and 节次 is not null)")
      If Cells(mh, "h") = "" Then GoTo aa
      conn.Execute ("update [安排$z1:af1000] set 学生=学生-1 where 代码=" & Cells(mh, 8).Value)
aa: Next mh
  conn.Close: Set conn = Nothing
  Range("h:h,z:cc").ClearContents
  Application.ScreenUpdating = True
End Sub
该程序没有任何问题，但就是不能实现全部功能，也就是不能将全部学生排完。究其原因：这部分未排学生，自己可用的节次与所剩的节次冲突，比如张三只剩第3节可用，但某一课程却只剩第1节，导致无法排课。我试了很多方法，均不能圆满解决。我也试过，从不同的学生开始排课，未排的结果是不一样，所以，有个最笨的方法，依次循环，直到正确为止。但需要时间太长。
最好的建议：不在排上做文章，而是在选上下功夫，做一个选课系统，能选即是可行的。

779846526

liangmutou01 发表于 2019-1-21 14:44
这个问题真的有难度，希望能看到更加的处理方式。
Sub kcap()
  Dim conn As Object, mh As Long

太谢谢您的帮助，再次谢谢

779846526

liangmutou01 发表于 2019-1-21 14:44
这个问题真的有难度，希望能看到更加的处理方式。
Sub kcap()
  Dim conn As Object, mh As Long

老师好，方便做个附件吗， 我测试时程序运行不完，一直在转