ป้อนข้อมูลที่ชีท1ให้ข้อมูลไปเก็บในตารางชีท3 ครับ

[pongpang]

ต้องการนำข้อมูลจากชีทที่ 1 วางในชีทที่ 3 (ตารางเก็บข้อมูล) โดยเมื่อป้อนข้อมูลในชีทที่1 และป้อนข้อมูลไม่เรียงตามลำดับเลขที่ ครั้งละ 1 เลขที่ เมื่อคลิกปุ่มข้อมูลจะนำไปวางในชีทที่3และจะสามารถสลับที่เรียงตามลำดับได้ ข้อมูลในเลขที่เดียวกันถ้าแก้ไขข้อมูลเสร็จเมื่อคลิกข้อมูลในเลขที่นั้นจะแก้ไขด้วย ครับ

ผลปรากฎว่า
1. ข้อมูลที่ป้อนข้อมูลจะไม่ครบตามจำนวนที่ป้อนไป
2. ข้อมูลจะไม่เรียงตามลำดับ
3. ไม่สามารถแก้ไขข้อมูลได้ ถ้าหากแก้ไขข้อมูลเมื่อคลิกก็จะไปเพิ่มในตารางเก็บข้อมูลด้วย
จะต้องปรับปรุงและแก้ไข Code นี้ อน่างไร ครับ

Code: Select all

Sub PasteData()
    Dim irRange As Range
    Dim lngRowNum As Long
    Dim lngPosition As Long
    Dim lr As Long
     With Worksheets("sheet3").Application
        lngRowNum = .WorksheetFunction.CountIf(Range("b16:b" & Range("B65536").End(xlUp).Row), Range("c4"))
        If lngRowNum = 0 Then
            Sheets("sheet1").Range("c4:c8").Copy
            Sheets("sheet3").Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True
        Else
        With Worksheets("sheet3").Application
            lngPosition = .WorksheetFunction.Match(Range("c4"), Range("b16:b" & Range("b" & Rows.Count).End(xlUp).Row), 0)
            Sheets("sheet1").Range("c4:c8").Copy
            Sheets("sheet3").Range("B" & (15 + lngPosition)).PasteSpecial xlPasteValues, Transpose:=True
            End With
        End If
        With Worksheets("sheet3")
            lr = Range("B" & Rows.Count).End(xlUp).Row
            Set irRange = Sheets("sheet3").Range("b16:f" & lr)
            irRange.Sort Key1:=Sheets("sheet3").Range("b16"), Order1:=xlAscending, Header:=xlGuess
        End With
    End With
    
End Sub

ขอบคุณล่วงหน้าครับ

[snasui]

ใน Sheet3 ลบค่าในบรรทัดที่ 27 ออกไปแล้วลองทดสอบดูใหม่ ในเครื่องผมไม่พบว่า Code มีปัญหา สามารถ Run ได้ตามปกติครับ

[pongpang]

ขอบคุณ คุณคนควน มากครับ ผมได้ปฏิบัติตามคำแนะนำแล้วครับ แต่
แต่ผลปรากฎว่า เมื่อทดลองป้อนข้อมูลตามลำดับเลขที่ คือ 10 9 5 8 เลขที่ 5 ถูกลบออกไป ดังภาพที่ 1 ครับ

1.png

และเมื่อป้อนข้อมูลต่อไป ตามเลขที่ 10 9 5 8 6 4 8 เลขที่ 5 ถูกลบออกไป และเมื่อแก้ไขข้อมูลของเลขที่ 8 จะนำไปบันทึกเป็น 2 แถว ครับ ตามภาพที่ 2 ครับ
ความต้องการ คือ ไม่ลบเลขที่ใด ๆ และแก้ไขข้อมูลไม่เก็บเป็น 2 แถว ต้องการให้เปลี่ยนเป็นข้อมูลใหม่ ครับ

[snasui]

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

Code: Select all

Sub PasteData()
    Dim irRange As Range
    Dim lngRowNum As Long
    Dim lngPosition As Long
    Dim lr As Long
    With Worksheets("sheet3")
        lngRowNum = Application.WorksheetFunction.CountIf(.Range("b16:b" & .Range("B65536").End(xlUp).Row), .Range("c4"))
        If lngRowNum = 0 Then
            Sheets("sheet1").Range("c4:c8").Copy
            Sheets("sheet3").Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True
        Else
        With Worksheets("sheet3")
            lngPosition = Application.WorksheetFunction.Match(.Range("c4"), .Range("b16:b" & .Range("b" & Rows.Count).End(xlUp).Row), 0)
            Sheets("sheet1").Range("c4:c8").Copy
            Sheets("sheet3").Range("B" & (15 + lngPosition)).PasteSpecial xlPasteValues, Transpose:=True
            End With
        End If
        With Worksheets("sheet3")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
            Set irRange = Sheets("sheet3").Range("b16:f" & lr)
            irRange.Sort Key1:=Sheets("sheet3").Range("b16"), Order1:=xlAscending, Header:=xlGuess
        End With
    End With
End Sub

สังเกตภายใต้ With Worksheets("Sheet3") จะมีการใช้ .Range ไม่ใช่ Range

[pongpang]

ขอบคุณ คุณคนควน มากครับ
ผมได้แก้ไขCode ตามที่แนะนำทุกประการแล้วครับ แต่ผลเป็นดังนี้ครับ
เมื่อป้อนข้อมูลต่อไป ตามเลขที่ 10 9 5 8 6 4 8เมื่อแก้ไขข้อมูลของเลขที่ 8 จะนำไปบันทึกเป็น 2 แถว ครับ ตามภาพ ครับ

[niwat2811]

ผมลองทดสอบ Code ที่ท่านอาจารย์ให้มาก็ใช้ได้เป็นปกตินะครับ ถ้ายังไงลองตรวจสอบดูอีกครั้งครับ

[pongpang]

ขอบคุณ คุณniwat2811

ผมลองทดสอบ Code ที่ท่านอาจารย์ให้มาก็ใช้ได้เป็นปกตินะครับ ถ้ายังไงลองตรวจสอบดูอีกครั้งครับ

ที่ช่วยตรวจสอบครับ แต่ลองอีกครั้งครับ ขอให้ลองตามภาพและดูไฟล์ด้วยครับ ถ้าได้ตามต้องการ คือ เมื่อบันทึกเลขที่เดิมซ้ำ ข้อมูลเลขที่นั้นต้องไม่มากกว่า 1 แถวครับ

ผล1.png

[snasui]

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

Code: Select all

Sub PasteData()
    Dim irRange As Range
    Dim lngRowNum As Long
    Dim lngPosition As Long
    Dim lr As Long
    With Worksheets("sheet3")
        lngRowNum = Application.WorksheetFunction.CountIf( _
            .Range("b16:b" & .Range("B65536").End(xlUp).Row), Sheets("Sheet1").Range("c4"))
        If lngRowNum = 0 Then
            Sheets("sheet1").Range("c4:c8").Copy
            Sheets("sheet3").Range("B65536").End(xlUp).Offset(1, 0) _
                .PasteSpecial xlPasteValues, Transpose:=True
        Else
        With Worksheets("sheet3")
            lngPosition = Application.WorksheetFunction.Match( _
                Sheets("Sheet1").Range("c4"), .Range("b16:b" & .Range("b" & Rows.Count) _
                .End(xlUp).Row), 0)
            Sheets("sheet1").Range("c4:c8").Copy
            Sheets("sheet3").Range("B" & (15 + lngPosition)) _
                .PasteSpecial xlPasteValues, Transpose:=True
            End With
        End If
        With Worksheets("sheet3")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
            Set irRange = Sheets("sheet3").Range("b16:f" & lr)
            irRange.Sort Key1:=Sheets("sheet3").Range("b16"), _
                Order1:=xlAscending, Header:=xlGuess
        End With
    End With
End Sub

[pongpang]

ขอบคุณ คุณคนควน มาก ครับ
ได้ตรงตามความต้องการครับ ขอบคุณมากครับ