#排座系统#
- 网上现成的少(可能自己不会找)
- 用matlab等语言实现,有些慢
- Excel上运行VBA实现简单,基本每台电脑都安装有,方便
Sub 随机排座()
Dim list_sheet As Worksheet
Dim names(500) As String
Dim name_count, max_name_count As Integer
Dim column_capacities(50) As Integer
Dim column_count, max_column_count As Integer
Dim weights(500) As Double
Dim d1, d2, d3 As Double
Dim str1, str2 As String
Dim i, j, k As Integer
max_name_count = 200 '允许的最大学生数
max_column_count = 20 '允许的最大列数(含走廊)
Set list_sheet = ThisWorkbook.Sheets("输入人员")
name_count = 0
For i = 1 To max_name_count
str1 = list_sheet.Cells(i, 1).Value
str1 = Trim(str1)
If str1 = "" Then
Exit For
Else
name_count = name_count + 1
names(name_count) = str1
End If
Next i
For i = 1 To name_count
weights(i) = Rnd()
Next i
For i = 1 To name_count - 1
For j = 1 To name_count - i
If weights(j) > weights(j + 1) Then
d1 = weights(j)
weights(j) = weights(j + 1)
weights(j + 1) = d1
str1 = names(j)
names(j) = names(j + 1)
names(j + 1) = str1
End If
Next j
Next i
column_count = 0
Set list_sheet = ThisWorkbook.Sheets("输入布局")
For i = 2 To max_column_count
str1 = list_sheet.Cells(i, 1).Value
str1 = Trim(str1)
If str1 = "" Then
Exit For
Else
column_count = column_count + 1
column_capacities(column_count) = Int(str1)
End If
Next i
Application.ScreenUpdating = False
'颜色
Dim c1, c2, chead As Variant
chead = list_sheet.Cells(2, 4).Interior.Color
c1 = list_sheet.Cells(3, 4).Interior.Color
c2 = list_sheet.Cells(4, 4).Interior.Color
Set list_sheet = ThisWorkbook.Sheets("随机排座")
For i = 1 To 30
For j = 1 To max_column_count
list_sheet.Cells(i, j).Value = ""
list_sheet.Cells(i, j).Interior.Color = RGB(255, 255, 255)
Next j
Next i
If column_count > 0 Then
list_sheet.Cells(1, column_count / 2).Value = "讲台"
End If
k = 1
For i = 1 To column_count
If column_capacities(i) = 0 Then
str1 = "走廊"
Else
str1 = "第" + Trim(Str(k)) + "列"
k = k + 1
End If
list_sheet.Cells(1 + 1, i).Value = str1
list_sheet.Cells(1 + 1, i).Interior.Color = chead
Next i
k = 1
Dim lines As Integer
lines = 0
For i = 1 To column_count
For j = 1 To column_capacities(i)
If k > name_count Then
Exit For
End If
list_sheet.Cells(j + 1 + 1, i).Value = names(k)
If j + 2 > lines Then
lines = j + 2
End If
If j Mod 2 = 0 Then
list_sheet.Cells(j + 1 + 1, i).Interior.Color = c1
Else
list_sheet.Cells(j + 1 + 1, i).Interior.Color = c2
End If
k = k + 1
Next j
If k > name_count Then
Exit For
End If
Next i
For i = 2 To lines
For j = 1 To column_count
list_sheet.Cells(i, j).Borders.LineStyle = xlContinuous
Next j
Next i
Application.ScreenUpdating = True
End Sub
备注:Excel代码是同事写的,没经过同意(应该也不介意,好东西大家一起分享);
使用方法:
1. 打开EXCEL,再按下键盘组合键 alt+F11 打开VBA编辑器;
2. 菜单“插入”--->选“模块”,弹出的模块,将上面的代码粘贴上,保存。