如何根据原始表班级各功能室座次按功能室座号生成班级座位表以姓名代替座次

yzyyyyyyy · 发表于 2016-4-8 11:23

如何根据原始表班级各功能室座次按功能室座号生成班级座位表以姓名代替座次.rar (9.56 KB, 下载次数: 14) 原始表：各年级，各班级，姓名，学生在各功能室的座号
参数表：各功能室列表，该功能室座次表是否输出，输出哪些班级
各功能室模板：安排就座的座位号，年级班级，人数。
目标：
1、按参数表中的顺序，依次分功能室生成相应班级座次表，各班级间加分页符。
2、将功能室相应班级的座位号填充为相应班级的学生姓名。
3、填写表格中的年级班级，人数。
4、生成的功能室座次表要与模板中的行间距、列距保持一致。

蓝桥玄霜 · 发表于 2016-4-8 15:33

请见代码。
这是显示全部班级的，其它可自行扩展。

chxw68 · 发表于 2016-4-8 18:35

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Dim ws As Worksheet
Dim reg As New RegExp
Dim rng As Range
Dim lk(), hg()
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Worksheets("参数表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:e" & r)
For i = 1 To UBound(arr)
If arr(i, 4) = "是" Then
If Not d1.exists(arr(i, 2)) Then
Set d1(arr(i, 2)) = CreateObject("scripting.dictionary")
End If
If arr(i, 5) = "全部" Then
d1(arr(i, 2))("*") = ""
Else
brr = Split(arr(i, 5), ",")
For j = 0 To UBound(brr)
d1(arr(i, 2))(Val(brr(j))) = ""
Next
End If
End If
Next
End With
With reg
.Global = True
.Pattern = Join(d1.keys, "|")
End With
With Worksheets("原始表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
For j = 1 To UBound(arr, 2)
Set mh = reg.Execute(arr(1, j))
If mh.Count > 0 Then
xm = mh(0)
If d1.exists(xm) Then
Set d(xm) = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
If d1(xm).exists("*") Or d1(xm).exists(arr(i, 2)) Then
If Not d(xm).exists(arr(i, 2)) Then
Set d(xm)(arr(i, 2)) = CreateObject("scripting.dictionary")
End If
d(xm)(arr(i, 2))(arr(i, j)) = arr(i, 4)
End If
Next
End If
End If
Next
End With
For Each ws In Worksheets
d2(ws.Name) = ""
Next
For Each aa In d.keys
wjm = aa & "成品"
If d2.exists(wjm) Then
With Worksheets(wjm)
.Cells.Clear
End With
Else
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = wjm
End With
End If
If d2.exists(aa & "模板") Then
For Each bb In d(aa).keys
With Worksheets(aa & "模板")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(8, .Columns.Count).End(xlToLeft).Column
ReDim hg(1 To r)
ReDim lk(1 To c)
For i = 1 To r
hg(i) = .Rows(i).RowHeight
Next
For j = 1 To c
lk(j) = .Columns(j).ColumnWidth
Next
arr = .Range("a1").Resize(r, c)
For i = 8 To r
For j = 1 To c
If d(aa)(bb).exists(.Cells(i, j).Value) Then
.Cells(i, j) = d(aa)(bb)(.Cells(i, j).Value)
End If
Next
Next
Set rng = .UsedRange.Find(what:="年级班", LookIn:=xlValues, lookat:=xlWhole)
If Not rng Is Nothing Then
rng.Offset(0, 1) = bb
End If
Set rng = .UsedRange.Find(what:="人数", LookIn:=xlValues, lookat:=xlWhole)
If Not rng Is Nothing Then
rng.Offset(0, 1) = d(aa)(bb).Count
End If
With Worksheets(wjm)
r1 = .Cells(.Rows.Count, 1).End(xlUp).Row
If r1 > 1 Then
r1 = r1 + 1
End If
End With
.UsedRange.Copy Worksheets(wjm).Cells(r1, 1)
With Worksheets(wjm)
For i = 1 To UBound(hg)
.Rows(r1 + i - 1).RowHeight = hg(i)
Next
End With
.UsedRange = arr
End With
Next
With Worksheets(wjm)
For j = 1 To UBound(lk)
.Columns(j).ColumnWidth = lk(j)
Next
End With
End If
Next
End Sub

复制代码

chxw68 · 发表于 2016-4-8 18:37

详见附件。

chxw68 · 发表于 2016-4-9 08:12

加了分页符。

punny · 发表于 2018-9-9 08:51

正想弄个生成班级座位表，这有参考了。

		自动登录	找回密码
密码			免费注册

[求助] 如何根据原始表班级各功能室座次按功能室座号生成班级座位表以姓名代替座次

评分

评分

评分

评分