รบกวนดู Code ให้หน่อยครับ

[snoopy1150]

เรียน ทุกท่าน ครับ


เนื่องจากผมทำ From ขึ้นมาตัวหนึ่ง ซึ่งถ้าเปลี่ยน ข้อมูลหลัก แล้ว ส่วนรายละเอียดจะมาเอง

แต่ผมติดตรง Code ซึ่ง มันชอบลบหัวบรรทัดออก

จึงอยากสอบถามว่า ผมเขียน Code ผิดตรงไหนครับ หรือต้องแก้ตรงไหนครับ

ทั้งนี้ผมได้แนบ Code กับเอกสารมาด้วย ครับ

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("Data Return")
      Set rAll = .Range("C2", .Range("C" & rl).End(xlUp))
    End With
    For Each r In rAll
        If r = Worksheets("From Return").Range("B3") Then
            lng = lng + 1
            ReDim Preserve a(5, lng)
            a(1, lng) = lng
            a(2, lng) = r.Offset(0, 2)
            a(3, lng) = r.Offset(0, 3)
            a(4, lng) = r.Offset(0, 4)
            a(5, lng) = r.Offset(0, 6)
        End If
    Next r
    If lng > 0 Then
        With Worksheets("From Return")
        Set rt = .Range("A6", .Range("E" & lng - 1 + 3))
            If .Range("A5") <> "" Then
              .Range("A6:E6", Selection.End(xlDown)).ClearContents
            End If
        
        .Range("A6:E6").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
        .Range("A6:E6").End(xlDown).Offset(1, 0).ClearContents
      End With
    Else
      MsgBox "Data not found."
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[snasui]

ลองปรับ Code เป็นตามด้านล่างครับ

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("Data Return")
      Set rAll = .Range("C2", .Range("C" & rl).End(xlUp))
    End With
    For Each r In rAll
        If r = Worksheets("From Return").Range("B3") Then
            lng = lng + 1
            ReDim Preserve a(5, lng)
            a(1, lng) = lng
            a(2, lng) = r.Offset(0, 2)
            a(3, lng) = r.Offset(0, 3)
            a(4, lng) = r.Offset(0, 4)
            a(5, lng) = r.Offset(0, 6)
        End If
    Next r
    If lng > 0 Then
        With Worksheets("From Return")
        Set rt = .Range("A6", .Range("E" & lng - 1 + 5))
            If .Range("A6") <> "" Then
              .Range("A6", .Range("E6").End(xlDown)).ClearContents
            End If
        .Range("A6:E6").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
      End With
    Else
      MsgBox "Data not found."
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
End Sub

[snoopy1150]

เรียน คุณ คนควน

ขอบคุณครับ