สอบถามปัญหา CodeVB ลบข้อมูลใน Cell ที่ไม่ต้องการ

[tigerwit]

จากไฟล์ที่แนบ
ต้องการลบข้อมูลที่เป็นคะแนนตั้งแต่ คลอลัมน์ C ถึง P โดยมีเงื่อนไขว่า
ถ้าคลอลัมน์ A แถวไหนไม่มีข้อมูล ให้ลบข้อมูลที่มีในคลอลัมน์ C ถึง P

Code: Select all

Sub clsScore()
    Dim lastRow As Long
    Dim i As Long, r As Range
    With Worksheets("Page1")
    Range("A2").Select
        Set r = .Range("A2")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
        Loop
          lastRow = r.Offset(i - 1, 0).Row
        If Selection.Row <= lastRow Then
'        Range(lastRow).Select
         Range("C9:P12").Select
'         Selection.ClearContents
        End If
        End With
End Sub

จะต้องเขียน Code เพิ่มอย่างไรครับ

[puriwutpokin]

ลองปรับเป็น

Code: Select all

Sub clsScore()
    Dim lastRow As Long
    Dim i As Long, r As Range
    With Worksheets("Page1")
    lastRow = .Cells(.Rows.Count, 17).End(xlUp).Row
    For i = 2 To lastRow
    If .Cells(i, 1) = "" Then
     .Cells(i, 2).Resize(, 15).ClearContents
     End If
    Next i
    End With
End Sub

[tigerwit]

ขอบคุณครับมีข้อสงสัยครับ
บรรทัดนี้
lastRow = .Cells(.Rows.Count, 17).End(xlUp).Row
เลข 17 หมายถึงอะไรครับ

[puriwutpokin]

ขอบคุณครับมีข้อสงสัยครับ
บรรทัดนี้
lastRow = .Cells(.Rows.Count, 17).End(xlUp).Row
เลข 17 หมายถึงอะไรครับ

เลขคอลัมน์​ครับที่หาค่าสุดท้าย​ครับ

[tigerwit]

สอบถามต่อครับ กรณีที่เราต้องการจะลบข้อมูลกับชีทอื่น ๆ ที่มีโครงสร้างแบบเดียวกัน ประมาณ 10-15 ชีท
Code ที่เขียนจะต้อง With Worksheets .................................End With ไปจนครบทุกชีทใช่หรือไม่ครับ
หรือสามารถย่อให้สั้นได้กว่านี้

Code: Select all

Sub clsScore()
    Dim lastRow As Long
    Dim i As Long, r As Range
    With Worksheets("thai")
        lastRow = .Cells(.Rows.Count, 44).End(xlUp).Row
    lastRow = .Cells(.Rows.Count, 17).End(xlUp).Row
    For i = 6 To lastRow
    If .Cells(i, 2) = "" Then
     .Cells(i, 6).Resize(, 14).ClearContents
     .Cells(i, 21).Resize(, 2).ClearContents
   .Cells(i, 26).Resize(, 14).ClearContents
      .Cells(i, 41).Resize(, 2).ClearContents
     End If
    Next i
    End With
    With Worksheets("Eng")
    lastRow = .Cells(.Rows.Count, 44).End(xlUp).Row
    lastRow = .Cells(.Rows.Count, 17).End(xlUp).Row
    For i = 6 To lastRow
    If .Cells(i, 2) = "" Then
     .Cells(i, 6).Resize(, 14).ClearContents
     .Cells(i, 21).Resize(, 2).ClearContents
   .Cells(i, 26).Resize(, 14).ClearContents
      .Cells(i, 41).Resize(, 2).ClearContents
     End If
    Next i
    End With
    With Worksheets("pysical")
'    With Worksheets.Sheet3
    lastRow = .Cells(.Rows.Count, 44).End(xlUp).Row
    lastRow = .Cells(.Rows.Count, 17).End(xlUp).Row
    For i = 6 To lastRow
    If .Cells(i, 2) = "" Then
     .Cells(i, 6).Resize(, 14).ClearContents
     .Cells(i, 21).Resize(, 2).ClearContents
   .Cells(i, 26).Resize(, 14).ClearContents
      .Cells(i, 41).Resize(, 2).ClearContents
     End If
    Next i
    End With
      With Worksheets("sci")
'    With Worksheets.Sheet3
    lastRow = .Cells(.Rows.Count, 44).End(xlUp).Row
    lastRow = .Cells(.Rows.Count, 17).End(xlUp).Row
    For i = 6 To lastRow
    If .Cells(i, 2) = "" Then
     .Cells(i, 6).Resize(, 14).ClearContents
     .Cells(i, 21).Resize(, 2).ClearContents
   .Cells(i, 26).Resize(, 14).ClearContents
      .Cells(i, 41).Resize(, 2).ClearContents
     End If
    Next i
    End With
End Sub

[Bo_ry]

Code: Select all

Sub cls()
Dim sh As Worksheet, l&
For Each sh In ThisWorkbook.Sheets
   l = sh.[D6].End(xlDown).Row + 1
    sh.Range(Replace("F#:S50,U#:V50,Z#:AM50,AO#:AP50", "#", l)).ClearContents
Next
End Sub

[tigerwit]

Code: Select all

Sub cls()
Dim sh As Worksheet, l&
For Each sh In ThisWorkbook.Sheets
   l = sh.[D6].End(xlDown).Row + 1
    sh.Range(Replace("F#:S50,U#:V50,Z#:AM50,AO#:AP50", "#", l)).ClearContents
Next
End Sub

ขอบคุณครับ
code สั้นมาก ยังมีปัญหาอยู่ครับ
แต่เนื่องจากว่า
1. ในไฟล์ยังมีชีทอื่นอีกจำนวนมาก ที่โครงสร้างชีทไม่เหมือนตัวอย่าง เมื่อรันโค๊ดแล้ว ทำให้ไปลบข้อมูลในชีทอื่นๆ ไปด้วย
2. กรณีนักเรียนครบแถวสุดท้ายที่ 45 คน รันโค๊ดแล้ว จะไปลบคะแนนคนที่ 45 ออก ซึ่งไม่ต้องการแบบนั้น

ต้องการใช้กับชีทที่มีโครงสร้างแบบตัวอย่าง (รายวิชาต่างๆ) เหมือนกัน มีทั้งหมด 15 ชีทเท่านั้นครับ

[Bo_ry]

Code: Select all

Sub cls()
Dim sh, l&
For Each sh In Array("Thai", "Eng", "Pysical", "Sci", "Social", "Techno")
    With Sheets(sh)
        l = .[D6].End(xlDown).Row + 1
        .Range(Replace("F#:S999,U#:V999,Z#:AM999,AO#:AP999", "#", l)).ClearContents
    End With
Next
End Sub

[tigerwit]

Code: Select all

Sub cls()
Dim sh, l&
For Each sh In Array("Thai", "Eng", "Pysical", "Sci", "Social", "Techno")
    With Sheets(sh)
        l = .[D6].End(xlDown).Row + 1
        .Range(Replace("F#:S999,U#:V999,Z#:AM999,AO#:AP999", "#", l)).ClearContents
    End With
Next
End Sub

ขอบคุณครับ...
เหลือติดอีกนิดหนึ่งครับ
กรณี เซลว่าง ว่างจริงๆ ไม่มีสูตรเชื่อมโยงข้อมูลมาจากชีทอื่น Code ใช้ได้ผล
แต่ ถ้าเซลว่าง เนื่องจากชีทต้นทางที่เชื่อมโยงมาว่าง กรณีนี้ Code ใช้ไม่ได้ผลครับ
ตามไฟล์ที่แนบมา

[Bo_ry]

เงื่อนไขไม่ต้องเพิ่มทีละนิดทีละหน่อย
เพิ่มมาทีเดียวให้ครบเลยนะครับ จะได้ตอบทีเดียว

[tigerwit]

เงื่อนไขไม่ต้องเพิ่มทีละนิดทีละหน่อย
เพิ่มมาทีเดียวให้ครบเลยนะครับ จะได้ตอบทีเดียว

ติดตรงนี้สุดท้ายแล้วครับ
ขอบคุณครับผม

[snasui]

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

Code: Select all

Dim sh As Worksheet, r As Range, l As Integer
For Each sh In Worksheets
    If sh.Range("b1").MergeCells Then
        With sh
            l = Application.CountIfs(.Range("d6:d100"), "?*")
            For Each r In .Range("d" & l + 6, "as51")
                If Not r.Locked Then
                    r.ClearContents
                End If
            Next r
        End With
    End If
Next sh

[Bo_ry]

Code: Select all

Sub cls()
Dim sh As Worksheet, l&
l = Application.Max(Sheets("Student").[B:B])
For Each sh In ThisWorkbook.Sheets
    If sh.[b6] = 1 Then
        sh.Unprotect
        sh.Range(Replace("F#:S58,U#:V58,Z#:AM58,AO#:AP58", "#", l + 6)).ClearContents
        sh.Protect
    End If
Next
End Sub

[tigerwit]

สูตรนี้

Code: Select all

Dim sh As Worksheet, r As Range, l As Integer
For Each sh In Worksheets
    If sh.Range("b1").MergeCells Then
        With sh
            l = Application.CountIfs(.Range("d6:d100"), "?*")
            For Each r In .Range("d" & l + 6, "as51")
                If Not r.Locked Then
                    r.ClearContents
                End If
            Next r
        End With
    End If
Next sh

เราสามารถใส่ชื่อชีทลงไปได้เลยหรือไม่ครับ (มี 12 ชีท)
เพื่อลดการการค้นหาชีทที่มีอยู่ในไฟล์ทั้งหมด (40 กว่าชีท) ที่เข้าเงื่อนไข (If sh.Range("b1").MergeCells Then)

[snasui]

ปรับตรง For Each sh In Worksheets เป็น For Each sh In Worksheets(array("Sheet1","Sheet2","Sheet3")) เช่นนี้เป็นต้นครับ

[tigerwit]

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

Code: Select all

Sub ClsOverScore2()
    Dim lastRow As Long
    Dim i As Long, r As Range, j As Long
    
      With Worksheets("ไทย")
        Set r = .Range("D6")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
        Loop
    .Range(r.Offset(i, 1), .Range("R" & .Rows.Count).End(xlUp)).ClearContents
        End With
        
      With Worksheets("ไทย")
        Set r = .Range("S6")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
        Loop
        .Range(r.Offset(i, 1), .Range("U" & .Rows.Count).End(xlUp)).ClearContents
        End With
        
          With Worksheets("ไทย")
        Set r = .Range("X6")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
        Loop
                        .Range(r.Offset(i, 1), .Range("AL" & .Rows.Count).End(xlUp)).ClearContents
        End With
        
        With Worksheets("ไทย")
        Set r = .Range("AM6")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
        Loop
                        .Range(r.Offset(i, 1), .Range("AO" & .Rows.Count).End(xlUp)).ClearContents
        End With
        
End Sub

แต่โค้ด ลักษณะเดียวกันนี้

Code: Select all

Sub ClsOverScore()
    Dim lastRow As Long
    Dim i As Long, r As Range, j As Long
    
    With Worksheets("EvaAttib")
        Set r = .Range("D6")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
        Loop
    .Range(r.Offset(i, 1), .Range("H" & .Rows.Count).End(xlUp)).ClearContents
        End With
    With Worksheets("EvaAttib")
        Set r = .Range("I6")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
        Loop
                        .Range(r.Offset(i, 1), .Range("M" & .Rows.Count).End(xlUp)).ClearContents
        End With
            With Worksheets("EvaAttib")
        Set r = .Range("N6")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
        Loop
                        .Range(r.Offset(i, 1), .Range("O" & .Rows.Count).End(xlUp)).ClearContents
        End With
        
End Sub

ใช้งานได้กับชีท EvaAttib
ไม่ทราบว่าผิดตรงไหนครับ

[snasui]

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

Code: Select all

Sub ClsOverScore2()
    Dim lastRow As Long
    Dim i As Long, r As Range, j As Long
    
    With Worksheets("ä·Â")
        Set r = .Range("D6")
        Do While r.Offset(i, 0).Value <> ""
            i = i + 1
            j = r.Offset(i, 0).Row
        Loop
        lastRow = .Range("e" & .Rows.Count).End(xlUp).Row
        .Range("d" & j, .Range("r" & lastRow)).ClearContents
        .Range("y" & j, .Range("al" & lastRow)).ClearContents
        .Range("an" & j, .Range("ao" & lastRow)).ClearContents
    End With
End Sub

[tigerwit]

ขอบคุณครับผม
ปรับนิดหน่อยใช้งานได้แล้วครับผม

Code: Select all

Sub ClsOverScore2()
    Dim lastRow As Long
    Dim i As Long, r As Range, j As Long
    
    With Worksheets("ไทย")
        Set r = .Range("D6")
        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
End Sub