VBA高手帮帮忙，帮我把年级成绩按班级分开来

ldyzmjx

这是我的年级成绩表，请各位高手帮帮忙把各班成绩从年级成绩里面自动提出出来到各自工作表中

约定的童话

一键拆分到各个班级工作表里面？（新建班级工作表？）

wodewan

Sub main()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim d As Object, arr, i&, j&, sht, BT
BT = Sheets("总成绩").[A3:M3]
Set d = CreateObject("scripting.dictionary")
arr = Sheets("总成绩").[a3].CurrentRegion.Offset(3)
For Each sht In Sheets
If sht.Name <> "总成绩" Then sht.Delete
Next
For i = 1 To UBound(arr) - 3
    d(arr(i, 1)) = ""
Next
For i = 0 To d.Count - 1
    Sheets.Add.Name = d.keys()(i)
    Set sht = Sheets(d.keys()(i))
    Call tq(arr, sht, BT)
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub tq(arr, sht, BT)
Dim i&, j&, m&
For i = 1 To UBound(arr)
If arr(i, 1) = sht.Name Then
    m = m + 1
    For j = 1 To UBound(arr, 2)
    arr(m, j) = arr(i, j)
    Next
End If
Next
sht.[A1].Resize(1, UBound(BT, 2)) = BT
sht.[a2].Resize(m, UBound(arr, 2)) = arr
End Sub

hiyou

无需VBA，数据处理即可
你这个表的数据分段做得很好，除了有表头操作起来稍麻烦一点，要选定数据
有班组字段的情况下，做一下数据筛选即可

xyxcc177

筛选、复制、粘贴几分钟完事，比VBA写代码的时间要短，真不知怎么想的？

ldyzmjx

约定的童话 发表于 2019-11-14 10:12
一键拆分到各个班级工作表里面？（新建班级工作表？）

谢谢，能不能把做好的发给我？

xuqing8331

拆分到新工作簿如附件

astupig

1. Sub Test()
   
2.    
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("总成绩").[a3].CurrentRegion
   
5.     For i = 4 To UBound(arr)
   
6.         d(arr(i, 1)) = ""
   
7.     Next i
   
8.    
   
9.     For Each k In d.keys
   
10.         Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
    
11.         ws.Name = k
    
12.         n = 0
    
13.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
14.         For i = 4 To UBound(arr)
    
15.             If arr(i, 1) = k Then
    
16.                 n = n + 1
    
17.                 For j = 1 To UBound(arr, 2)
    
18.                     brr(n, j) = arr(i, j)
    
19.                 Next j
    
20.             End If
    
21.         Next i
    
22.         titleArr = Sheets("总成绩").Range("A3:M3")
    
23.         ws.[a1].Resize(1, UBound(arr, 2)) = titleArr
    
24.         ws.[a2].Resize(n, UBound(arr, 2)) = brr
    
25.     Next
    
26. 
    
27. End Sub
    

复制代码

astupig

或者用自动筛选。。。。

1. Sub test()
   
2.     arr = Array("1班", "2班", "3班", "4班", "5班")
   
3.     lastRow = Sheets("总成绩").[a19999].End(xlUp).Row
   
4.     For Each ar In arr
   
5.         Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
   
6.         ws.Name = ar
   
7.         Sheets("总成绩").Range("$A$3:$M$" & lastRow).AutoFilter Field:=1, Criteria1:=ar
   
8.         Sheets("总成绩").Cells.Copy ws.[a1]
   
9.     Next
   
10. End Sub

复制代码

stonelee2018

已拆分，下载试用