การแสดงข้อมูลจากฐานข้อมูลตามเงื่อนไขด้วย VBA

[raweeroge]

สวัสดีครับ คือผมลองทำตามตัวอย่างที่อาจารย์แสดงไว้ที่ Microsoft Excel Tips and Tricks แต่ติดขัดครับ ไม่ทราบว่าต้องทำยังไงต่อครับ และผมก็มีข้อมูลที่ต้องเพิ่มขึ้นตลอด

Creat Formula Project 46.xlsm

Code วางไว้ที่ชีท Report

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$2" And Target <> "" Then
        Group
    ElseIf Target.Address = "$E$2" And Target = "" Then
        MsgBox "Please select data."
    End If
End Sub

และ Code นี้วางไว้ที่ Work Book

Code: Select all

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("A2", .Range("A" & rl).End(xlUp))
    End With
    For Each r In rAll
        If r = Worksheets("Report").Range("E2") Then
            lng = lng + 1
            ReDim Preserve a(5, lng)
            a(1, lng) = lng
            a(2, lng) = r.Offset(0, 10)
            a(3, lng) = r.Offset(0, -9)
            a(4, lng) = r.Offset(0, -8)
            a(5, lng) = r.Offset(0, -7)
        End If
    Next r
    If lng > 0 Then
        With Worksheets("Report")
            Set rt = .Range("A4", .Range("G" & lng - 1 + 5))
            .Range("A4", .Range("A" & rl).End(xlUp).Offset(0, 4)).ClearContents
            .Range("A5:G5").Copy
            rt.PasteSpecial xlPasteFormats
            rt = Application.Transpose(a)
            .Range("D4", .Range("D" & rl).End(xlUp)).NumberFormat = "000000"
            .Range(.Range("A4").End(xlDown).Offset(1, 0), .Range("G" & rl)).Clear
            .Range("E2").Activate
        End With
    Else
        MsgBox "Data not found."
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[bank9597]

อีกทางเลือกครับ

Code: Select all

Sub Group()

        Dim rWs As Worksheet
        Dim tWs As Worksheet
        Dim tRange As Range
        Dim tAll As Range
        Dim lngLastRow As Long
        Dim lngNextRow As Long
        Dim strCon As String
        
        Set rWs = Sheets("Report")
        Set tWs = Sheets("Database")
        
        strCon = rWs.Range("E2")
        lngLastRow = tWs.Range("A" & Rows.Count).End(xlUp).Row
        Set tAll = tWs.Range("A2:A" & lngLastRow)
        lngNextRow = 4
        rWs.UsedRange.Offset(3, 0).ClearContents
        For Each tRange In tAll
            If tRange = strCon Then
                rWs.Range("A" & lngNextRow) = rWs.Range("A" & lngNextRow).Row - 3
                rWs.Range("B" & lngNextRow) = tRange.Offset(1, 0)
                rWs.Range("C" & lngNextRow) = tRange.Offset(2, 0)
                rWs.Range("D" & lngNextRow) = tRange.Offset(3, 0)
                rWs.Range("E" & lngNextRow) = tRange.Offset(4, 0)
                rWs.Range("F" & lngNextRow) = tRange.Offset(5, 0)
                rWs.Range("G" & lngNextRow) = tRange.Offset(6, 0)

            End If
            lngNextRow = rWs.Range("A" & Rows.Count).End(xlUp).Row + 1
        Next tRange
        
        
        Set rWs = Nothing
        Set tWs = Nothing
        Set tAll = Nothing
        
End Sub

[snasui]

สวัสดีครับ คือผมลองทำตามตัวอย่างที่อาจารย์แสดงไว้ที่ Microsoft Excel Tips and Tricks แต่ติดขัดครับ ไม่ทราบว่าต้องทำยังไงต่อครับ

Code นี้ไม่เหมาะสำหรับมือใหม่ นอกจากนี้การนำ Code ที่ผมเขียนไว้มาถามนั้น จะต้องปรับปรุงมาเองก่อนเสมอ ไม่ใช่ยกต้นแบบมาถามโดยไม่มีการปรับปรุงใด ๆ และเมื่อปรับเองแล้วจะต้องบอกได้ว่าติดขัดบรรทัดใด จะได้ช่วยตอบต่อไปจากนั้นครับ