'----------------------------------------------------------
' 高中排课系统 V2.0
' 功能：30个班级自动排课，支持硬约束和软约束
' 作者：AI助手
' 日期：2023-10-15
'----------------------------------------------------------
Option Explicit
' 全局常量定义
Global Const DAYS_PER_WEEK As Integer = 5 ' 每周5个工作日
Global Const MORNING_PERIODS As Integer = 4 ' 上午4节课
Global Const AFTERNOON_PERIODS As Integer = 4 ' 下午4节课
Global Const TOTAL_PERIODS As Integer = 8 ' 每天8节课
Global Const MAX_CLASSES As Integer = 30 ' 最大班级数
' 工作表常量
Global Const CLASSINDX_SHEET As String = "班级索引"
Global Const TEACHERINDX_SHEET As String = "教师索引"
Global Const CLASS_SCHEDULE_SHEET As String = "班级课表"
Global Const TEACHER_SCHEDULE_SHEET As String = "教师课表"
' 数据结构定义
Type ClassInfo
classID As String ' 班级ID (如 "高一(1)")
Subject As String ' 科目
Teacher As String ' 教师
HoursPerWeek As Integer ' 每周课时数
isMainSubject As Boolean ' 是否主科
End Type
Type TeacherInfo
teacherID As String ' 教师ID
Subject As String ' 教学科目
Classes() As String ' 任教班级数组
TotalHours As Integer ' 总课时数
End Type
Type ScheduleCell
Subject As String ' 科目
Teacher As String ' 教师
classID As String ' 班级ID
End Type
' 全局变量
Global ClassData() As ClassInfo ' 班级数据数组
Global TeacherData() As TeacherInfo ' 教师数据数组
Global ClassSchedules() As ScheduleCell ' 班级课表(班级, 天, 节)
Global TeacherSchedules() As ScheduleCell ' 教师课表(教师, 天, 节)
Global ClassIndexDict As Object ' 班级索引字典
Global TeacherIndexDict As Object ' 教师索引字典
Sub MainScheduler()
' 主排课程序
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
' 1. 初始化工作表和数据结构
InitializeSystem
' 2. 加载数据
LoadClassData "ClassInfo"
LoadTeacherData "TeacherInfo"
' 3. 验证数据完整性
If Not ValidateData() Then
MsgBox "数据验证失败，请检查输入数据", vbCritical
Exit Sub
End If
' 4. 初始化排课表
InitializeSchedules
' 5. 执行排课算法
GenerateTimetable
' 6. 导出课表
ExportClassSchedules
ExportTeacherSchedules
MsgBox "排课完成！" & vbCrLf & "班级课表: " & CLASS_SCHEDULE_SHEET & vbCrLf & _
"教师课表: " & TEACHER_SCHEDULE_SHEET, vbInformation
Exit Sub
End Sub
Sub InitializeSystem()
' 创建必要的工作表
CreateSheet CLASSINDX_SHEET
CreateSheet TEACHERINDX_SHEET
CreateSheet CLASS_SCHEDULE_SHEET
CreateSheet TEACHER_SCHEDULE_SHEET
' 初始化字典
Set ClassIndexDict = CreateObject("Scripting.Dictionary")
Set TeacherIndexDict = CreateObject("Scripting.Dictionary")
End Sub
Sub CreateSheet(sheetName As String)
' 创建工作表（如果不存在）
On Error Resume Next
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(sheetName)
If ws Is Nothing Then
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sheetName
Else
ws.Cells.ClearContents
End If
End Sub
Sub LoadClassData(sheetName As String)
' 从指定工作表加载班级数据
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(sheetName)
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' 初始化班级数据数组
ReDim ClassData(1 To lastRow - 2)
Dim i As Long, rowIndex As Long
For i = 3 To lastRow ' 从第3行开始（标题在第2行）
rowIndex = i - 2
With ClassData(rowIndex)
.classID = CStr(ws.Cells(i, 1).Value) ' A列：班级ID
.Subject = CStr(ws.Cells(i, 2).Value) ' B列：科目
.Teacher = CStr(ws.Cells(i, 3).Value) ' C列：教师
.HoursPerWeek = CInt(ws.Cells(i, 4).Value) ' D列：周课时
.isMainSubject = (ws.Cells(i, 5).Value = "是") ' E列：是否主科
End With
' 添加到班级索引字典
If Not ClassIndexDict.Exists(ClassData(rowIndex).classID) Then
ClassIndexDict.Add ClassData(rowIndex).classID, rowIndex
End If
Next i
End Sub
Sub LoadTeacherData(sheetName As String)
' 从指定工作表加载教师数据
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(sheetName)
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' 初始化教师数据数组
ReDim TeacherData(1 To lastRow - 1)
Dim i As Long, rowIndex As Long, classArr() As String
For i = 2 To lastRow ' 从第3行开始（标题在第2行）
rowIndex = i - 1
With TeacherData(rowIndex)
.teacherID = CStr(ws.Cells(i, 1).Value) ' A列：教师ID
.Subject = CStr(ws.Cells(i, 2).Value) ' B列：科目
.TotalHours = 0 ' 初始化为0
' 解析任教班级（C列：逗号分隔的班级列表）
classArr = Split(ws.Cells(i, 3).Value, ",")
ReDim .Classes(1 To UBound(classArr) + 1)
Dim j As Integer
For j = 0 To UBound(classArr)
.Classes(j + 1) = Trim(classArr(j))
Next j
End With
' 添加到教师索引字典
TeacherIndexDict.Add TeacherData(rowIndex).teacherID, rowIndex
Next i
End Sub
Function ValidateData() As Boolean
' 数据验证逻辑
Dim i As Long, j As Long
Dim classHours(1 To MAX_CLASSES) As Integer
Dim teacherHours As Object
Set teacherHours = CreateObject("Scripting.Dictionary")
Dim key As Variant
' 1. 检查班级总课时
For i = 1 To UBound(ClassData)
Dim classID As String
classID = ClassData(i).classID
' 累加每个班级的总课时
If ClassIndexDict.Exists(classID) Then
classHours(ClassIndexDict(classID)) = classHours(ClassIndexDict(classID)) + ClassData(i).HoursPerWeek
End If
Next i
' 验证每个班级总课时=40
For i = 1 To MAX_CLASSES
If classHours(i) > 0 And classHours(i) > DAYS_PER_WEEK * TOTAL_PERIODS Then
MsgBox "班级 " & ClassData(i).classID & " 总课时(" & classHours(i) & ")不符合要求(40)", vbExclamation
ValidateData = False
Exit Function
End If
Next i
' 2. 教师课时验证
For i = 1 To UBound(TeacherData)
teacherHours(TeacherData(i).teacherID) = 0
Next i
' 计算每个教师的总课时
For i = 1 To UBound(ClassData)
If TeacherIndexDict.Exists(ClassData(i).Teacher) Then
Dim teacherID As String
teacherID = ClassData(i).Teacher
teacherHours(teacherID) = teacherHours(teacherID) + ClassData(i).HoursPerWeek
Else
MsgBox "教师 " & ClassData(i).Teacher & " 未在教师表中定义", vbExclamation
ValidateData = False
' Exit Function
End If
Next i
' 验证教师课时是否合理（不超过40课时）
For Each key In teacherHours.Keys
If teacherHours(key) > DAYS_PER_WEEK * TOTAL_PERIODS Then
MsgBox "教师 " & key & " 课时(" & teacherHours(key) & ")超过最大限制(40)", vbExclamation
ValidateData = False
Exit Function
End If
Next
ValidateData = True
End Function
Sub InitializeSchedules()
' 初始化课表数据结构
ReDim ClassSchedules(1 To MAX_CLASSES, 1 To DAYS_PER_WEEK, 1 To TOTAL_PERIODS)
ReDim TeacherSchedules(1 To UBound(TeacherData), 1 To DAYS_PER_WEEK, 1 To TOTAL_PERIODS)
End Sub
Sub GenerateTimetable()
' 核心排课算法（优化版）
' 第一优先级：安排主科到上午
Dim i As Long
For i = 1 To UBound(ClassData)
If ClassData(i).isMainSubject Then
ScheduleSubject i, True
End If
Next i
' 第二优先级：安排其他科目
For i = 1 To UBound(ClassData)
If Not ClassData(i).isMainSubject Then
ScheduleSubject i, False
End If
Next i
' 第三优先级：填充空白并优化
OptimizeTimetable
End Sub
Sub ScheduleSubject(classIndex As Long, isMainSubject As Boolean)
' 安排单个科目
Dim scheduledHours As Integer
scheduledHours = 0
Dim maxAttempts As Integer
maxAttempts = 100
Do While scheduledHours < ClassData(classIndex).HoursPerWeek And maxAttempts > 0
Dim day As Integer, period As Integer
' 主科优先安排在上午 (1-4节)
If isMainSubject Then
day = Int(Rnd * DAYS_PER_WEEK) + 1
period = Int(Rnd * MORNING_PERIODS) + 1
Else
' 非主科可安排在下午 (5-8节)
day = Int(Rnd * DAYS_PER_WEEK) + 1
period = Int(Rnd * AFTERNOON_PERIODS) + MORNING_PERIODS + 1
End If
Dim classID As String
classID = ClassData(classIndex).classID
' 检查时间槽是否可用
If IsClassTimeSlotEmpty(classID, day, period) And _
IsTeacherAvailable(ClassData(classIndex).Teacher, day, period) Then
' 占用时间槽
With ClassSchedules(ClassIndexDict(classID), day, period)
.Subject = ClassData(classIndex).Subject
.Teacher = ClassData(classIndex).Teacher
.classID = classID
End With
' 更新教师课表
Dim teacherIndex As Integer
teacherIndex = TeacherIndexDict(ClassData(classIndex).Teacher)
With TeacherSchedules(teacherIndex, day, period)
.Subject = ClassData(classIndex).Subject
.Teacher = ClassData(classIndex).Teacher
.classID = classID
End With
scheduledHours = scheduledHours + 1
End If
maxAttempts = maxAttempts - 1
Loop
' 如果未排满课时，尝试强制安排
If scheduledHours < ClassData(classIndex).HoursPerWeek Then
ForceScheduleSubject classIndex, ClassData(classIndex).HoursPerWeek - scheduledHours
End If
End Sub
Sub ForceScheduleSubject(classIndex As Long, hoursToSchedule As Integer)
' 强制安排剩余课时（当正常排课失败时）
Dim classID As String
classID = ClassData(classIndex).classID
Dim teacherID As String
teacherID = ClassData(classIndex).Teacher
Dim teacherIndex As Integer
teacherIndex = TeacherIndexDict(teacherID)
Dim day As Integer, period As Integer
For day = 1 To DAYS_PER_WEEK
For period = 1 To TOTAL_PERIODS
If hoursToSchedule <= 0 Then Exit Sub
' 只填充空时间段
If IsClassTimeSlotEmpty(classID, day, period) And _
IsTeacherAvailable(teacherID, day, period) Then
' 占用时间槽
With ClassSchedules(ClassIndexDict(classID), day, period)
.Subject = ClassData(classIndex).Subject
.Teacher = teacherID
.classID = classID
End With
With TeacherSchedules(teacherIndex, day, period)
.Subject = ClassData(classIndex).Subject
.Teacher = teacherID
.classID = classID
End With
hoursToSchedule = hoursToSchedule - 1
End If
Next period
Next day
End Sub
Function IsClassTimeSlotEmpty(classID As String, day As Integer, period As Integer) As Boolean
' 检查班级时间槽是否为空
Dim classIdx As Integer
If ClassIndexDict.Exists(classID) Then
classIdx = ClassIndexDict(classID)
If ClassSchedules(classIdx, day, period).Subject = "" Then
IsClassTimeSlotEmpty = True
Exit Function
End If
End If
IsClassTimeSlotEmpty = False
End Function
Function IsTeacherAvailable(teacherID As String, day As Integer, period As Integer) As Boolean
' 检查教师时间槽是否可用
If TeacherIndexDict.Exists(teacherID) Then
Dim teacherIdx As Integer
teacherIdx = TeacherIndexDict(teacherID)
If TeacherSchedules(teacherIdx, day, period).Subject = "" Then
IsTeacherAvailable = True
Exit Function
End If
End If
IsTeacherAvailable = False
End Function
Sub OptimizeTimetable()
' 优化课表：减少空节，避免教师冲突，平衡课程分布
Dim i As Integer, day As Integer, period As Integer
' 1. 填补空白时间段
For i = 1 To MAX_CLASSES
For day = 1 To DAYS_PER_WEEK
' 检查上午是否有空节
Dim morningEmpty As Boolean
morningEmpty = False
For period = 1 To MORNING_PERIODS
If ClassSchedules(i, day, period).Subject = "" Then
morningEmpty = True
Exit For
End If
Next period
' 如果有空节，尝试填充
If morningEmpty Then
FillMorningGaps i, day
End If
Next day
Next i
' 2. 平衡教师每日课时
BalanceTeacherWorkload
End Sub
Sub FillMorningGaps(classIndex As Integer, day As Integer)
' 填补班级上午空节
Dim period As Integer, subjectIndex As Long
For period = 1 To MORNING_PERIODS
If ClassSchedules(classIndex, day, period).Subject = "" Then
' 尝试找到可移动的非主科课程
For subjectIndex = 1 To UBound(ClassData)
If Not ClassData(subjectIndex).isMainSubject And _
ClassData(subjectIndex).classID = ClassSchedules(classIndex, 1, 1).classID Then
Dim targetPeriod As Integer
' 找到该科目在下午的上课时间
For targetPeriod = MORNING_PERIODS + 1 To TOTAL_PERIODS
If ClassSchedules(classIndex, day, targetPeriod).Subject = ClassData(subjectIndex).Subject Then
' 交换时间段
SwapClassPeriods classIndex, day, period, targetPeriod
Exit For
End If
Next targetPeriod
End If
Next subjectIndex
End If
Next period
End Sub
Sub SwapClassPeriods(classIndex As Integer, day As Integer, period1 As Integer, period2 As Integer)
' 交换两个时间段
Dim temp As ScheduleCell
temp = ClassSchedules(classIndex, day, period1)
ClassSchedules(classIndex, day, period1) = ClassSchedules(classIndex, day, period2)
ClassSchedules(classIndex, day, period2) = temp
' 更新教师课表
Dim teacherIndex1 As Integer, teacherIndex2 As Integer
If ClassSchedules(classIndex, day, period1).Teacher <> "" Then
teacherIndex1 = TeacherIndexDict(ClassSchedules(classIndex, day, period1).Teacher)
TeacherSchedules(teacherIndex1, day, period1) = ClassSchedules(classIndex, day, period1)
End If
If ClassSchedules(classIndex, day, period2).Teacher <> "" Then
teacherIndex2 = TeacherIndexDict(ClassSchedules(classIndex, day, period2))
TeacherSchedules(teacherIndex2, day, period2) = ClassSchedules(classIndex, day, period2)
End If
End Sub
Sub BalanceTeacherWorkload()
' 平衡教师每日工作量
Dim teacherIndex As Integer, day As Integer, i As Integer
For teacherIndex = 1 To UBound(TeacherData)
Dim dailyHours(1 To DAYS_PER_WEEK) As Integer
' 统计教师每日课时
For day = 1 To DAYS_PER_WEEK
dailyHours(day) = 0
For i = 1 To TOTAL_PERIODS
If TeacherSchedules(teacherIndex, day, i).Subject <> "" Then
dailyHours(day) = dailyHours(day) + 1
End If
Next i
Next day
' 如果某天课时过多（例如超过6节），尝试调整
For day = 1 To DAYS_PER_WEEK
If dailyHours(day) > 3 Then
AdjustTeacherSchedule teacherIndex, day, dailyHours(day) - 6
End If
Next day
Next teacherIndex
End Sub
Sub AdjustTeacherSchedule(teacherIndex As Integer, busyDay As Integer, hoursToMove As Integer)
' 调整教师过于集中的课时
Dim targetDay As Integer, period As Integer, i As Integer
targetDay = FindLightestDay(teacherIndex)
For period = 1 To TOTAL_PERIODS
If hoursToMove <= 0 Then Exit Sub
' 检查繁忙时段是否有课
If TeacherSchedules(teacherIndex, busyDay, period).Subject <> "" Then
' 检查目标时段是否空闲
If TeacherSchedules(teacherIndex, targetDay, period).Subject = "" Then
' 移动课程到目标时段
MoveTeacherClass teacherIndex, busyDay, period, targetDay, period
hoursToMove = hoursToMove - 1
End If
End If
Next period
End Sub
Function FindLightestDay(teacherIndex As Integer) As Integer
' 找到教师课时最少的一天
Dim day As Integer, i As Integer
Dim minHours As Integer, lightestDay As Integer
minHours = TOTAL_PERIODS + 1
For day = 1 To DAYS_PER_WEEK
Dim hoursCount As Integer
hoursCount = 0
For i = 1 To TOTAL_PERIODS
If TeacherSchedules(teacherIndex, day, i).Subject <> "" Then
hoursCount = hoursCount + 1
End If
Next i
If hoursCount < minHours Then
minHours = hoursCount
lightestDay = day
End If
Next day
FindLightestDay = lightestDay
End Function
Sub MoveTeacherClass(teacherIndex As Integer, fromDay As Integer, fromPeriod As Integer, toDay As Integer, toPeriod As Integer)
' 移动教师的课程到新时段
Dim classID As String
classID = TeacherSchedules(teacherIndex, fromDay, fromPeriod).classID
' 更新教师课表
TeacherSchedules(teacherIndex, toDay, toPeriod) = TeacherSchedules(teacherIndex, fromDay, fromPeriod)
TeacherSchedules(teacherIndex, fromDay, fromPeriod).Subject = ""
TeacherSchedules(teacherIndex, fromDay, fromPeriod).Teacher = ""
TeacherSchedules(teacherIndex, fromDay, fromPeriod).classID = ""
' 更新班级课表
Dim classIndex As Integer
classIndex = ClassIndexDict(classID)
ClassSchedules(classIndex, toDay, toPeriod) = ClassSchedules(classIndex, fromDay, fromPeriod)
ClassSchedules(classIndex, fromDay, fromPeriod).Subject = ""
ClassSchedules(classIndex, fromDay, fromPeriod).Teacher = ""
ClassSchedules(classIndex, fromDay, fromPeriod).classID = ""
End Sub
Sub ExportClassSchedules()
' 导出班级课表
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(CLASS_SCHEDULE_SHEET)
ws.Cells.Clear
' 创建表头
ws.Range("B1:F1").Value = Array("星期一", "星期二", "星期三", "星期四", "星期五")
ws.Range("A2:A9").Value = Application.Transpose(Array("第一节", "第二节", "第三节", "第四节", "第五节", "第六节", "第七节", "第八节"))
Dim classID As String, classIdx As Integer, day As Integer, period As Integer
Dim col As Integer, startCol As Integer
Dim dd As String
' 为每个班级创建课表区域
For classIdx = 1 To MAX_CLASSES
dd = "高一(" & classIdx & ")班"
If ClassIndexDict.Exists(dd) Then
classID = "高一(" & classIdx & ")"
col = (classIdx - 1) * 6 + 2 ' 每班占6列
' 添加班级标题
ws.Cells(1, col).Value = classID
ws.Cells(1, col).Resize(1, 5).Merge
ws.Cells(1, col).HorizontalAlignment = xlCenter
' 填充课表数据
For day = 1 To DAYS_PER_WEEK
For period = 1 To TOTAL_PERIODS
With ClassSchedules(classIdx, day, period)
If .Subject <> "" Then
ws.Cells(period + 1, col + day - 1).Value = _
.Subject & vbCrLf & .Teacher
ws.Cells(period + 1, col + day - 1).Borders.LineStyle = xlContinuous
End If
End With
Next period
Next day
End If
Next classIdx
' 格式美化
ws.Columns.AutoFit
ws.Rows.RowHeight = 60
ws.Cells.WrapText = True
ws.Cells.VerticalAlignment = xlCenter
ws.Cells.HorizontalAlignment = xlCenter
End Sub
Sub ExportTeacherSchedules()
' 导出教师课表
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(TEACHER_SCHEDULE_SHEET)
ws.Cells.Clear
' 创建表头
ws.Range("B1:F1").Value = Array("星期一", "星期二", "星期三", "星期四", "星期五")
ws.Range("A2:A9").Value = Application.Transpose(Array("第一节", "第二节", "第三节", "第四节", "第五节", "第六节", "第七节", "第八节"))
Dim teacherIdx As Integer, day As Integer, period As Integer
Dim rowOffset As Integer
' 为每个教师创建课表区域
rowOffset = 0
For teacherIdx = 1 To UBound(TeacherData)
' 添加教师标题
ws.Cells(rowOffset * 10 + 1, 1).Value = TeacherData(teacherIdx).teacherID & " - " & TeacherData(teacherIdx).Subject
ws.Cells(rowOffset * 10 + 1, 1).Font.Bold = True
' 填充课表数据
For day = 1 To DAYS_PER_WEEK
For period = 1 To TOTAL_PERIODS
With TeacherSchedules(teacherIdx, day, period)
If .Subject <> "" Then
ws.Cells(rowOffset * 10 + period + 1, day + 1).Value = _
.Subject & vbCrLf & .classID
ws.Cells(rowOffset * 10 + period + 1, day + 1).Borders.LineStyle = xlContinuous
End If
End With
Next period
Next day
rowOffset = rowOffset + 1
Next teacherIdx
' 格式美化
ws.Columns.AutoFit
ws.Rows.RowHeight = 40
ws.Cells.WrapText = True
ws.Cells.VerticalAlignment = xlCenter
ws.Cells.HorizontalAlignment = xlCenter
End Sub
'----------------------------------------------------------
' 辅助函数
'----------------------------------------------------------
Function GetClassIndex(classID As String) As Integer
' 获取班级索引
If ClassIndexDict.Exists(classID) Then
GetClassIndex = ClassIndexDict(classID)
Else
GetClassIndex = -1
End If
End Function
Function GetTeacherIndex(teacherID As String) As Integer
' 获取教师索引
If TeacherIndexDict.Exists(teacherID) Then
GetTeacherIndex = TeacherIndexDict(teacherID)
Else
GetTeacherIndex = -1
End If
End Function
将上述代码功能，用多种算法优化一下
SharedPreferences是Android中用于轻量级数据存储的接口，它以Key/Value方式管理数据。默认的MODE_PRIVATE模式保证数据私有，仅应用本身可访问。MODE_APPEND用于追加内容，而MODE_WORLD_*模式则允许其他应用读写。这些模式关乎文件的访问权限控制。
扫一扫
737
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
