ฐานข้อมูล

[pongpang]

เรียน คุณคนควนและอาจารย์ ทุกท่าน
สร้างแบบบันทึกข้อมูล
ปัญหาที่พบ ครับ คือ ถ้าจะแก้ไขข้อมูลของเลขที่ที่บันทึกแล้ว ในตางรางเก็บข้อมูลจะเก็บข้อมูลโดยเพิ่มอีก 1 แถว
ความต้องการ ให้สามารถเก็บข้อมูลทับ Row เดิม ครับ ไม่ทราบว่าจะต้องแก้ไขปรับปรุง Code ที่ส่วนใด ครับ

Code: Select all

Sub Paste()
    Dim irRange As Range
    Worksheets("sheet1").Range("c4:c8").Copy
    Worksheets("sheet1").Cells(65536, "B").End(xlUp) _
            .Offset(1, 0).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("c4").Select
    With Worksheets("sheet1")
        Set irRange = .Range("b16", .Range("f" & Rows.Count).End(xlUp))
        irRange.Borders.LineStyle = xlContinuous
        irRange.Sort Key1:=.Range("b16"), Order1:=xlAscending, Header:=xlGuess
    End With
End Sub

[snasui]

ตาม Code ที่แนบมาไม่พบว่าเป็น Code สำหรับการแก้ไขรายการเดิมครับ ให้เขียนมาก่อน ติดตรงไหนแล้วค่อยถามกันต่อครับ

[nattasiray]

ขั้นแรกคุณต้องใช้ฟังก์ชัน COUNTIF บน VBA Excel เพื่อตรวจสอบว่ามีข้อมูลหรือไม่

Code: Select all

dim lngRowNum As Long
lngRowNum = WorksheetFunction.COUNTIF(ช่วงกลุ่มเซลล์,เซลล์ที่รับค่ารหัส)

หากพบว่ามี จึงใช้ฟังก์ชัน MATCH บน VBA Excel เพื่อค้นหาหมายเลขตำแหน่งของรหัสในกลุ่มเซลล์ที่ต้องการ

Code: Select all

dim lngPosition As Long
lngPosition = WorksheetFunction.MATCH(เซลล์ที่รับค่ารหัส,ช่วงกลุ่มเซลล์,0)

จากนั้นนำค่าที่ได้ไปบวกเข้ากับหมายเลขบรรทัดของหัวตารางร่วมกับ Offset Propeties ครับ

หากไม่พบ ก็ให้นำข้อมูลไปต่อท้าย

[nattasiray]

ลองดูตัวอย่างจากแฟ้มครับ

[pongpang]

ตาม Code ที่แนบมาไม่พบว่าเป็น Code สำหรับการแก้ไขรายการเดิมครับ ให้เขียนมาก่อน ติดตรงไหนแล้วค่อยถามกันต่อครับ

เรียน คุณคนควน คุณนัฐ และ ทุกท่าน
ขอบคุณมากครับที่ได้กรุณา
ผมได้พยายามแล้วครับ พยายามนำ Codeที่ให้ไปใช้ และศึกษาไฟล์ที่ส่งไปให้ ก็ไม่เข้าใจ ครับ นำ Code ไปพยายามปรับปรุง จะ error ดังภาพ และ Code
ที่ปรับปรุงครั้งหลังสุด มีดังนี้

Code: Select all

Sub Paste()
    Dim irRange As Range
    Dim lngRowNum As Long
    Dim lngPosition As Long
   With Application
    lngRowNum = WorksheetFunction.CountIf(Range("b16:b65536"), Range("c4")).End(xlUp).Row
    lngPosition = WorksheetFunction.Match(Range("C4") & Range("B16:B65536"), 0).End(xlUp).Row
    Worksheets("sheet1").Range("c4:c8").Copy
    Worksheets("sheet1").Cells(65536, "B").End(xlUp) _
            .Offset(Range("b16"), lngPosition, lngRowNum, 0, 1, 5).PasteSpecial xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Range("c4").Select
    With Worksheets("sheet1")
        Set irRange = .Range("b16", .Range("f" & Rows.Count).End(xlUp))
        irRange.Borders.LineStyle = xlContinuous
        irRange.Sort Key1:=.Range("b16"), Order1:=xlAscending, Header:=xlGuess
    End With
End Sub

ขอความกรุณาด้วยครับ

[nattasiray]

ผิด 3 จุดครับ

lngRowNum = WorksheetFunction.CountIf(Range("b16:b65536"), Range("c4")).End(xlUp).Row
lngPosition = WorksheetFunction.Match(Range("C4") & Range("B16:B65536"), 0).End(xlUp).Row

Worksheets("sheet1").Cells(65536, "B").End(xlUp) _
.Offset(Range("b16"), lngPosition, lngRowNum, 0, 1, 5).PasteSpecial xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True


แก้เป็น
lngRowNum = WorksheetFunction.CountIf(Range("b16:b" & Range("B65536").End(xlUp).Row), Range("c4"))
If lngRowNum = 0 then
range("B65536").end(xlup).Offset(1,0).PasteSpecial xlPasteValues, Transpose:=True
else
lngRowNum =WorksheetFunction.Match(Range("C4"), Range("B16:B" & Range("B65536").End(xlUp).Row), 0)
range("B" & (15+lngRowNum)).PasteSpecial xlPasteValues, Transpose:=True
end if

[pongpang]

ขอบคุณ คุณณัฐ ครับ ผลการแก้ Code จะมีกล่องข้อความ ดังภาพที่แนบมาครับ และ Code ทั้งหมดมีดังนี้ครับ

Code: Select all

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

ไม่ทราบว่าจะต้องแก้ไขปรับปรุงที่ส่วนใดครับ

[snasui]

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

Code: Select all

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

[pongpang]

ขอบคุณ คุณคนควน และ คุณนัฐ มากครับ แต่ถ้าไม่ใส่ข้อมูลที่ C8 ในตารางเก็บข้อมูลจะไม่มีเส้นและไม่เรียงลำดับใหม่ให้ ครับ
ไม่ทราบว่าจะต้องเพิ่มเติม Code อย่างไรครับ จึงจะตีเส้นและเรียงลำดับข้อมูลในตารางให้ ครับ

[niwat2811]

Code: Select all

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

ลองปรับ Code เป็นแบบนี้ไม่ทราบตรงตามต้องการไหมครับ

[pongpang]

ได้แล้วครับ ขอบคุณ คุณniwat2811 มากครับ