VBA ดึงข้อมูลจากฐานข้อมูล

[sutham]

ผมได้ลองศึกษาข้อมูลเกี่ยวกับการใช้ VBA ในการดึงข้อมูลจากฐานข้อมูลมาแสดงรายงาน และลองปรับ code ก็ได้รัดับหนึ่งตามที่ต้องการ แต่ติดปัญหาอยู่นิดหนึ่ง คือ เมื่อผมเลือกห้อง (เซลล์ E2 ชีท report) เช่น เลือกเป็นห้อง 3 ซึ่งเป็นห้องที่ไม่มีข้อมูลในฐานข็อมูล จะแสดงข้อความแจ้งว่า "ไม่มีข้อมูลนักเรียนในห้องนี้" แต่หลังจากนั้นจะให้ข้อมูลที่แสดงออกมาเป็นค่าว่าง ผมได้ลองใช้ความรู้ที่พอมีเกี่ยวกับ VBA ปรับ code โดยเพิ่ม code

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 ที่ผมปรับ จะรัน code ได้ปกติ แต่เมื่อเลือกห้องใหม่ที่มีอยู่ในฐานข้อมูล เช่น ห้อง 1 หัวตาราง ในแถวที่ 4 ออกไปด้วย ผมจะต้องแก้ไข code ใหม่อย่างไรครับ

[DhitiBank]

ลองแบบนี้ครับ

ปรับโค้ดเป็นด้านล่างครับ

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

[DhitiBank]

ผมลองตัดโค้ดบางบรรทัดที่ไม่ต้องมีก็ได้ออกไปเพื่อให้กระชับขึ้นเล็กน้อยครับ

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