[已解决]求把总表中学生成绩按班复制到对应的表中的VBA代码。

仁声

有一个全年级学生成绩总表。现要先增加20个表，分别命名为1班、2班---20班。然后把总表中学生成绩按班复制到对应的表中。怎么用VBA完成。求取代码，因本人初学的菜鸟一个，最好有注释。

最佳答案

月排行榜 / 总排行榜

心正意诚身修

2016-1-6 12:16

复制的动作没有用数组,方便理解,但是运行起来有点慢

1. Sub test()
   
2. Dim l, a, x, r
   
3. Application.ScreenUpdating = False '关闭屏幕更新
   
4. On Error Resume Next
   
5. For l = 1 To 20 '1循环到20
   
6.       Sheets.Add(after:=Sheets(Sheets.Count)).Name = l & "班"  '批量插入工作表
   
7. Next
   
8. a = Sheets("总表").Range("a1").CurrentRegion '赋值总表的数据给数组a
   
9. For x = 3 To UBound(a)  '从第三行循环到最后一行
   
10.      Sheets(a(x, 1) & "班").Select '选中所在班级的工作表
    
11.      r = [a65536].End(3).Row + 1 '找到最后一个空行
    
12.      Sheets("总表").Rows(x).Copy Range("a" & r) '复制
    
13. Next
    
14. Application.ScreenUpdating = True '开启屏幕更新
    
15. End Sub
    

复制代码

跳转到最佳答案楼层

QCW911

有偿编写 有意加QQ 57726980

心正意诚身修

复制的动作没有用数组,方便理解,但是运行起来有点慢

1. Sub test()
   
2. Dim l, a, x, r
   
3. Application.ScreenUpdating = False '关闭屏幕更新
   
4. On Error Resume Next
   
5. For l = 1 To 20 '1循环到20
   
6.       Sheets.Add(after:=Sheets(Sheets.Count)).Name = l & "班"  '批量插入工作表
   
7. Next
   
8. a = Sheets("总表").Range("a1").CurrentRegion '赋值总表的数据给数组a
   
9. For x = 3 To UBound(a)  '从第三行循环到最后一行
   
10.      Sheets(a(x, 1) & "班").Select '选中所在班级的工作表
    
11.      r = [a65536].End(3).Row + 1 '找到最后一个空行
    
12.      Sheets("总表").Rows(x).Copy Range("a" & r) '复制
    
13. Next
    
14. Application.ScreenUpdating = True '开启屏幕更新
    
15. End Sub
    

复制代码

sry660

1. Sub 总表拆分()
   
2. Dim arr, d, i&, x, aa, iRow&, Sh As Worksheet
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. Sheets(1).Activate
   
6. iRow = Cells(Rows.Count, 1).End(xlUp).Row
   
7. arr = Range("a3:a" & iRow)
   
8. Set d = CreateObject("scripting.dictionary")
   
9. For i = 1 To UBound(arr)
   
10.     x = arr(i, 1)
    
11.     d(x) = ""
    
12. Next
    
13. aa = d.keys
    
14. For i = 0 To UBound(aa)
    
15.     With Sheets(1).Range("a2:k" & iRow)
    
16.         '.Select
    
17.         .AutoFilter field:=1, Criteria1:=aa(i)
    
18.     End With
    
19.     Sheets.Add after:=Sheets(Sheets.Count)
    
20.     Set Sh = ActiveSheet
    
21.     Sh.Name = aa(i)
    
22.     Sheets(1).UsedRange.SpecialCells(xlCellTypeVisible).Copy Sh.[a1]
    
23. Next
    
24. Application.DisplayAlerts = True
    
25. Application.ScreenUpdating = True
    
26. End Sub

复制代码

仁声

心正意诚身修 发表于 2016-1-6 12:16
复制的动作没有用数组,方便理解,但是运行起来有点慢

高手，非常感谢你的帮助。因为是菜鸟，还要慢慢研究。

仁声

sry660 发表于 2016-1-6 12:29

不错，只是没有注解，看得一片迷茫。呵呵， 还是非常感谢。