VBA把成绩表 按班级对成绩进行分类

laoau138

VBA把成绩表  按班级对成绩进行分类

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, d, sht As Worksheet
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set sht = Sheets("成绩表")
   
6. arr = sht.Range("a1").CurrentRegion
   
7. Application.ScreenUpdating = False
   
8. Application.DisplayAlerts = False
   
9. For Each sh In Sheets
   
10.     If sh.Name <> sht.Name Then sh.Delete
    
11. Next
    
12. For i = 2 To UBound(arr)
    
13.     d(arr(i, 3)) = ""
    
14. Next
    
15. For Each a In d.keys
    
16.     sht.[c3].AutoFilter Field:=3, Criteria1:=a
    
17.     With Sheets.Add(after:=Sheets(Sheets.Count))
    
18.         sht.[a:g].Copy .[a1]
    
19.         .Name = a
    
20.     End With
    
21. Next
    
22. sht.Activate
    
23. sht.ShowAllData
    
24. Application.DisplayAlerts = True
    
25. Application.ScreenUpdating = True
    
26. End Sub

复制代码

laoau138

dsmch 发表于 2016-11-26 15:38

还可以这样吧



Sub 按班整理成绩() '字典法
Dim i&, m&, arr
Dim d, k
Set d = CreateObject("Scripting.Dictionary")
m = [b65536].End(3).Row
arr = Range("A2:g" & m)
For i = 1 To UBound(arr)
    d(arr(i, 3)) = ""
Next
k = d.keys
ReDim brr(1 To UBound(arr), 1 To 7)
For i = 0 To d.Count - 1
    x = 0
    For j = 1 To UBound(arr)
        If arr(j, 3) = k(i) Then
           x = x + 1: brr(x, 1) = x
           For l = 2 To 7
               brr(x, l) = arr(j, l)
           Next
        End If
    Next
   Sheets(k(i)).Range("a2:g65536").ClearContents
   Sheets(k(i)).[a2].Resize(x, 7) = brr
Next
Set d = Nothing
End Sub