Snasui Excel Forum

Code: Select all

Sheets("report").Range("a5:E54").Value = ""

Code: Select all

Option Explicit
Option Base 1
Sub ShowEmp()
    Dim a() As Variant, lng As Long
    Dim r As Range, rAll As Range
    Dim rt As Range, rl As Long
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    rl = Rows.Count
    With Worksheets("Database")
        Set rAll = .Range("h2", .Range("h" & rl).End(xlUp))
    End With
    For Each r In rAll
        If r = Worksheets("Report").Range("C2") Then
            lng = lng + 1
            ReDim Preserve a(6, lng)
            a(1, lng) = lng
            a(2, lng) = r.Offset(0, -5)
            a(3, lng) = r.Offset(0, -4)
            a(4, lng) = r.Offset(0, -3)
            a(5, lng) = r.Offset(0, -2)
           a(6, lng) = r.Offset(0, -1)

        End If
    Next r
    If lng > 0 Then
        With Worksheets("Report")
            Set rt = .Range("A5", .Range("F" & lng - 1 + 5))
            .Range("A5", .Range("A" & rl).End(xlUp).Offset(0, 6)).ClearContents
            .Range("A5:G5").Copy
            rt.PasteSpecial xlPasteFormats
            rt = Application.Transpose(a)
            .Range(.Range("A4").End(xlDown).Offset(1, 0), .Range("F" & rl)).Clear
            .Range("E2").Activate
            
            'จัดเรียงข้อมูล
            Range("B5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("report").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("report").Sort.SortFields.Add Key:=Range("F5:F54"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("report").Sort.SortFields.Add Key:=Range("B5:B54"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("report").Sort
        .SetRange Range("B4:F54")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        
    End With
    Range("E2").Select
 End With
    Else
        MsgBox "ไม่มีข้อมูลนักเรียนในห้องนี้ !"
                       
        Sheets("report").Range("a5:E54").Value = ""     ' code ที่เพิ่ม ลงไป เมื่อเลือกห้องใหม่ที่มีข้อมูลในฐานข้อมูล หัวตารางจะถูกลบไปด้วย
        
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Code: Select all

'.....bla bla bla
If lng > 0 Then
        With Worksheets("Report")
            Set rt = .Range("A5", .Range("F" & lng - 1 + 5))
            .Range("a5:a" & .Rows.Count).ClearContents
'......bla bla bla

Code: Select all

Option Explicit
Option Base 1
Sub ShowEmp()
    Dim a() As Variant, lng As Long, rl As Long, i As Integer
    Dim r As Range, rAll As Range
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    rl = Rows.Count
    With Worksheets("Database")
        Set rAll = .Range("h2", .Range("h" & rl).End(xlUp))
    End With
    lng = 1
    ReDim a(rAll.Rows.Count, 6)
    For Each r In rAll
        If r.Value = Sheets("Report").Range("C2").Value Then
            a(lng, 1) = lng
            For i = 2 To 6
                a(lng, i) = r.Offset(0, i - 7)
            Next i
            lng = lng + 1
        End If
    Next r
    If lng - 1 > 0 Then
        With Sheets("Report")
            .Range("a6:f" & rl).Clear
            .Range("a5").Resize(rAll.Rows.Count, 6).Value = a
            rl = .Range("a" & rl).End(xlUp).Row
            .Range("a5:f5").Copy
            .Range("a6:f" & rl).PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
            
            'จัดเรียงข้อมูลใหม่
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("F4"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("B4"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Range("B4:F" & rl)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            .Range("E2").Select
        End With
    Else
        MsgBox "ไม่ข้อมูลนักเรียนในห้องนี้ !"
        Sheets("report").Range("a5:f" & rl).ClearContents
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub