สอบถาม CodeVB เคลียร์ข้อมูลที่เกิน

[tigerwit]

จากไฟล์ที่แนบมา

Code: Select all

Sub ClsOverScore() ' เคลียร์คะแนนที่เกินจำนวนคนที่มีชื่อ
    Dim lastRow As Long
    Dim i As Long, r As Range, j As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With ActiveSheet
        Set r = .Range("D5")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
            j = r.Offset(i, 0).Row
        Loop
        lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
        .Range("E" & j, .Range("R" & lastRow)).ClearContents
        .Range("T" & j, .Range("U" & lastRow)).ClearContents
        .Range("Y" & j, .Range("AL" & lastRow)).ClearContents
        .Range("AN" & j, .Range("AO" & lastRow)).ClearContents
End With

    MsgBox "เคลียร์คะแนนที่เกินมาเสร็จเรียบร้อยแล้ว"
    Range("E5").Select
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

ต้องการเคลียร์ข้อมูลที่เกินจากจำนวนนักเรียนที่มีอยู่จริง และคะแนนที่กรอกเกินช่องที่ไม่มีคะแนนเต็ม (ว่างหรือเป็น0)
ตอนนี้ Code สามารถเคลียนในส่วนที่เกินจำนวนนักเรียน แต่ยังไม่เคลียร์ในส่วนของที่เกินคะแนนเต็ม (ตามตัวอย่างในไฟล์ J5:R43,T5:U43,AC5:AL43)
ต้องปรับ Code อย่างไรครับ

[snasui]

ผมทดสอดู Code ที่แนบมาทำงานได้แล้วครับ

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

[tigerwit]

ขอบคุณครับ ที่ต้องการคือ ที่เกินไปทางขวามือ ก้ต้องการให้เคลียร์ด้วย โดย เช็คจากแถวที่ 4 หากมีค่าว่าง หรือเป็น 0

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub ClsOverScore() ' เคลียร์คะแนนที่เกินจำนวนคนที่มีชื่อ
    Dim lastRow As Long
    Dim i As Long, r As Range, j As Long
    On Error Resume Next
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With ActiveSheet
        Set r = .Range("D5")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
            j = r.Offset(i, 0).Row
        Loop
        lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
        .Range("E" & j, .Range("R" & lastRow)).ClearContents
        .Range("T" & j, .Range("U" & lastRow)).ClearContents
        .Range("Y" & j, .Range("AL" & lastRow)).ClearContents
        .Range("AN" & j, .Range("AO" & lastRow)).ClearContents
        For Each r In .Range("e4:v4, y4:am4")
            If r.Value = 0 Then
                .Range(.Cells(r.Row + 1, r.Column), _
                    .Cells(lastRow, r.Column)).ClearContents
            End If
        Next r
    End With

    MsgBox "เคลียร์คะแนนที่เกินมาเสร็จเรียบร้อยแล้ว"
    Range("E5").Select
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

[tigerwit]

ขอบคุณครับ
พอดีว่าได้ให้ gemini ทำโค๊ดให้ แล้วได้ผล

Code: Select all

Sub ClsOverBothWays_Final_WithEventFix()
    Dim r As Range, i As Long
    Dim checkCols As Range
    Dim startRow As Long, endRow As Long
    
    ' --- จุดสำคัญ: ต้องปิด Events ตั้งแต่เริ่ม ---
    Application.ScreenUpdating = False
    Application.EnableEvents = False
'    Application.Calculation = xlCalculationManual
    On Error GoTo CleanExit ' ป้องกันกรณี Error แล้ว Events ไม่ยอมเปิดกลับ

    Set checkCols = ActiveSheet.Range("E4:R4, T4:U4, Y4:AL4, AN4:AO4")
    startRow = 5
    endRow = 49
    
    With ActiveSheet
        ' 1. เคลียร์ตามคะแนนเต็ม (แถว 4)
        For Each r In checkCols
            If Val(r.Value) <= 0 Then
                .Range(.Cells(startRow, r.Column), .Cells(endRow, r.Column)).ClearContents
            End If
        Next r

        ' 2. เคลียร์ตามชื่อเด็ก (คอลัมน์ D)
        For i = startRow To endRow
            If Trim(.Cells(i, "D").Value) = "" Or .Cells(i, "D").Value = 0 Then
                Intersect(.Rows(i), checkCols.EntireColumn).ClearContents
            End If
        Next i
    End With

'    MsgBox "เคลียร์คะแนนที่เกินมาเสร็จเรียบร้อยแล้ว"
'    ActiveSheet.Range("E5").Select

CleanExit:
    ' --- จุดสำคัญ: ต้องเปิด Events กลับมาเสมอเพื่อให้ระบบกันก๊อปปี้ทำงานต่อได้ ---
'    Application.Calculation = xlCalculationAutomatic ' คืนค่าการคำนวณ
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "เคลียร์คะแนนที่เกินมาเสร็จเรียบร้อยแล้ว"
End Sub

'Sub ClsOverBothWays_Final_WithEventFix()
'    ' ... (ตัวแปรเดิม) ...
'
'    Application.ScreenUpdating = False
'    Application.EnableEvents = False
'    ' --- เพิ่มบรรทัดนี้เพื่อลดภาระการคำนวณหน้าจอ ---
'    Application.Calculation = xlCalculationManual
'
'    On Error GoTo CleanExit
'
'    ' --- บรรทัดสำคัญ: ปลดการเลือก Shape ทันทีที่เริ่มรัน ---
'    ActiveSheet.Range("A1").Select
'
'    ' ... (Logic การเคลียร์ข้อมูลเดิมของคุณ) ...
'CleanExit:
'    Application.Calculation = xlCalculationAutomatic ' คืนค่าการคำนวณ
'    Application.EnableEvents = True
'    Application.ScreenUpdating = True
'    MsgBox "เคลียร์คะแนนที่เกินมาเสร็จเรียบร้อยแล้ว"
'End Sub

แต่เมื่อ assign macro ลงใน Button กับ Shape แล้วการทำงานทำไมถึงเร็วต่างกันมาก
Button จะเร็วมาก ส่วน Shape จะรอประมาณ 10 วินาที มีสาเหตุเกิดจากอะไรครับ

[snasui]

ผมทดสอบแล้วพบว่าความเร็วไม่ต่างกัน ไม่มีการหน่วงใด ๆ ครับ