[已解决]把学生信息按班级填入另一张表中

llhwzxf

把学生信息按班级填入另一张表中

最佳答案

月排行榜 / 总排行榜

grf1973

2015-9-16 10:50

请看附件。在数据表里添加了一些各年级的数据供测试。

跳转到最佳答案楼层

高

都是一班的啊，空表还准备好了2班、3班……
难度没什么，只是，估计没有人愿意给你做苦工。

grf1973

1. Sub tt()
   
2.     Dim wb As Workbook, brr()
   
3.     Dim CopyRng As Range
   
4.     Set CopyRng = Sheets("样表").Range("a1:h31")     '要复制的表式
   
5.     xstr = "一二三四五六七八九"        '表式中班级为阿拉伯数字型，据此转换成中文数字
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\学生信息.xls")
   
9.     arr = wb.Worksheets(1).[a1].CurrentRegion
   
10.     wb.Close False
    
11.     For i = 2 To UBound(arr)
    
12.         x = arr(i, 2) & arr(i, 3)
    
13.         d(x) = d(x) & "," & arr(i, 1)      '年级+班级为key，姓名累加为item
    
14.         y = arr(i, 2)
    
15.         d1(y) = ""        '总共存在多少年级
    
16.     Next
    
17.     For Each y In d1.keys
    
18.         Worksheets.Add after:=Sheets(Sheets.Count)    '新建年级表
    
19.         With ActiveSheet
    
20.             .Name = y
    
21.             For i = 1 To 9
    
22.                 x = y & Mid(xstr, i, 1) & "班"           '年级+班级为key
    
23.                 If d.exists(x) Then
    
24.                     CopyRng.Copy .Cells((i - 1) * 32 + 1, 1)      '粘贴样表
    
25.                     .Cells((i - 1) * 32 + 3, 1) = "                  学校   " & Mid(y, 1, 1) & "    年级  " & i & "  班"
    
26.                     xrr = Split(d(x), ",")         '各姓名进数组xrr
    
27.                     ReDim brr(1 To 25, 1 To 8)         '显示数组
    
28.                     For k = 1 To UBound(xrr)
    
29.                         q = 2 * Int((k - 0.001) / 25) + 1
    
30.                         p = k Mod 25: If p = 0 Then p = 25
    
31.                         brr(p, q) = k
    
32.                         brr(p, q + 1) = xrr(k)
    
33.                     Next
    
34.                     .Cells((i - 1) * 32 + 5, 1).Resize(25, 8) = brr
    
35.                     .Cells((i - 1) * 32 + 30, 5) = k - 1           '本班人数
    
36.                 End If
    
37.             Next
    
38.         End With
    
39.     Next
    
40. End Sub
    

复制代码

grf1973

请看附件。在数据表里添加了一些各年级的数据供测试。