Nhờ các Anh, Chị giúp đỡ code cho nút lệnh tách mỗi lớp trong danh sách thành 1 sheet ạ!

[2013myvietnam]

Em có danh sách học sinh tuyển sinh vào lớp 6 ở Sheet DK_TS như ảnh dưới. Sau khi xếp lớp, em muốn tạo nút lệnh Tách lớp để tách mỗi lớp trong cột Xếp lớp thành 1 Sheet riêng và đặt tên sheet theo tên các lớp nhưng không biết viết code như thế nào cho nút lệnh. Các anh, chị giúp đỡ em với, em xin chân thành cảm ơn ạ!

 

[ptm0412]

Bài 17 vẫn còn dùng tới 2 vòng lặp: một để tạo dict và 1 để tạo mảng kết quả. Code sau đây chỉ 1 vòng lặp tạo 2 thứ trên.

Sub SplitSheet3()
Dim DictClass, SArr(), RArr(), ClassList(), ClassArr(), RArrChild()
Dim LastRw As Long, NextRw As Long, RwCount()
Application.ScreenUpdating = False
DeleteSheet
Set DictClass = CreateObject("Scripting.Dictionary")
With Sheet1
    LastRw = .[U2000].End(xlUp).Row
    SArr = .Range("A10:V" & LastRw).Value
    ClassList = .Range("U10:U" & LastRw).Value
End With
ReDim RArrChild(1 To UBound(SArr, 1), 1 To 22)

For m = 1 To UBound(ClassList, 1)
    If Not DictClass.exists(ClassList(m, 1)) Then
        k = k + 1
        DictClass.Add ClassList(m, 1), k
        ReDim Preserve RArr(1 To k)
        ReDim Preserve RwCount(1 To k)
        RArr(k) = RArrChild
    End If
    x = DictClass.Item(ClassList(m, 1))
    RwCount(x) = RwCount(x) + 1
    RArr(x)(RwCount(x), 1) = RwCount(x)
    For n = 2 To 22
        RArr(x)(RwCount(x), n) = SArr(m, n)
    Next
Next
ClassArr = DictClass.keys
For i = 1 To k
    Sheet1.Copy After:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = ClassArr(i - 1)
        .Range("A10:V1000").ClearContents
        .[A10].Resize(RwCount(i), 22).Value = RArr(i)
        NextRw = .[B100].End(xlUp).Row + 1
        .Range("A" & NextRw & ":V1000").Clear
        Sheet1.Range("A" & LastRw + 1).Resize(12, 22).Copy .Range("A" & NextRw)
    End With
Application.ScreenUpdating = True
Next    
End Sub