根据总表和班主任表生成班级表

hjd528

请各位老师帮一下：

1.如何根据总表和班主任表生成班级表，一个班级为一个工作表
2.班级表的第二行添上班级和班主任，第3列没有班级名称
3.格式、页面设置保持不变



根据总表和班主任表生成班级表.rar (31.85 KB, 下载次数: 19)

2024-2-1 18:58 上传

点击文件名下载附件

谢谢各位老师！

cjc209

cjc209

效果

hjd528

cjc209 发表于 2024-2-1 19:40

谢谢回帖，但我电脑里没有WPS。

sxbjzjf110

楼主试一下。。。。

hjd528

sxbjzjf110 发表于 2024-2-1 20:25
楼主试一下。。。。

非常感谢。添加了两行代码，将班级表的第一行标题栏的字体进行了设置，取消了边框线。
Range("A1:J1").Borders.LineStyle = xlNone
Range("A1:J1").Font.Size = 20

闻启学

   已经完成

lushang2018

1. Sub 测试()
   
2.     Dim i%, j%, k%, arr, brr
   
3.     Dim rng As Range, sht As Worksheet
   
4.     Dim dic As Object, key, keys
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     Set rng = Sheet1.Range("A1:J2")
   
7.     arr = Sheet1.Range("A3:J" & Sheet1.Cells(Rows.Count, "B").End(xlUp).Row)
   
8.     ReDim brr(1 To 100, 1 To 10)
   
9.     For i = LBound(arr) To UBound(arr)
   
10.         key = arr(i, 3)
    
11.         If Not dic.Exists(key) Then
    
12.             k = 0
    
13.             For j = 1 To 10
    
14.                 brr(1, j) = arr(i, j)
    
15.             Next
    
16.             dic(key) = brr
    
17.         Else
    
18.             brr = dic(key)
    
19.             k = k + 1
    
20.             For j = 1 To 10
    
21.                 brr(k + 1, j) = arr(i, j)
    
22.             Next
    
23.             dic(key) = brr
    
24.         End If
    
25.     Next
    
26.     keys = dic.keys
    
27.     For i = LBound(keys) To UBound(keys)
    
28.         key = keys(i)
    
29.         brr = dic(key)
    
30.         Set sht = Sheets.Add
    
31.         sht.Name = key
    
32.         sht.Range("A1") = rng.Copy
    
33.         sht.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    
34.         sht.Range("A2") = "班级:"
    
35.         sht.Range("B2") = key
    
36.         sht.Range("H2") = "班主任:"
    
37.         sht.Range("I2") = 班主任(Sheets("班主任"), key)
    
38.         sht.Range("A4").Resize(UBound(brr), 10) = brr
    
39.         sht.Columns(3).Delete
    
40.     Next
    
41. End Sub
    
42. Function 班主任(sht As Worksheet, key)
    
43.     Dim arr
    
44.     arr = sht.Range("A1").CurrentRegion
    
45.     For i = 2 To UBound(arr)
    
46.         If arr(i, 1) = key Then
    
47.             班主任 = arr(i, 2)
    
48.         End If
    
49.     Next
    
50. End Function

复制代码

hjd528

闻启学 发表于 2024-2-1 21:32
已经完成

谢谢！但每个班级表还要进行页面设置。

闻启学

根据总表和班主任表生成班级表.zip (73.91 KB, 下载次数: 25)

2024-2-1 22:01 上传

点击文件名下载附件

  请查看文件