รบกวนสอบถามอาจารย์เรื่อง Protect Sheet Code VBA ครับ

[Tahiti80s]

รบกวนสอบถามอาจารย์เรื่อง Protect Sheet Code VBA ครับ
เนื่องจากเวลาเรากดส่งข้อมูลไปยัง Sheet ต่างๆ จะทำการส่งข้อมูลไปยัง Sheet ต่างๆ แล้วสามารถล๊อค Sheet ได้ แต่ถ้าเรากดที่ Bottom box เปล่าๆ นั้นมันจะปลดล๊อค Sheet อยากทราบว่ามีวิธีการแก้ไขอย่างไรครับ คืออยากให้มันล๊อคตลอดและก็clear content ได้ด้วยครับ รบกวนด้วยครับ ขอบคุณครับ

Code: Select all

Sub Button1_Click()

    Dim historyWks As Worksheet
    Dim inputWks As Worksheet

    Dim nextRow As Long
    Dim oCol As Long

    Dim myRng As Range
    Dim myCopy As String
    Dim myCell As Range
    ActiveSheet.Unprotect Password:="1234" '<==UnProtect
    Sheets("Input").Unprotect Password:="1234"
    'cells to copy from Input sheet - some contain formulas
    myCopy = "E5:E7"

    Set inputWks = Worksheets("Input")
    Set historyWks = Worksheets("defectdata")

    With historyWks
        nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    End With

    With inputWks
    Set myRng = .Range(myCopy)
        If Not ActiveWorkbook.Saved Then
        Msg = "ท่านกรอกข้อมูลครบถ้วนหรือไม่?"
 
        Ans = MsgBox(Msg, vbQuestion + vbYesNo)
        Select Case Ans
            Case vbYes
                ThisWorkbook.Saved = True
            Case vbNo
                 Cancel = True
           
                Exit Sub
          End Select
    End If
    If Application.CountA(myRng) <> myRng.Cells.Count Then
            MsgBox "กรุณาใส่ข้อมูลให้ครบถ้วน"
            Exit Sub
        End If
    End With


       
    With historyWks
        'With .Cells(nextRow, "A")
           ' .Value = Now
            '.NumberFormat = "mm/dd/yyyy hh:mm:ss"
        'End With
        '.Cells(nextRow, "B").Value = Application.UserName
        oCol = 1
        For Each myCell In myRng.Cells
            historyWks.Cells(nextRow, oCol).Value = myCell.Value
            oCol = oCol + 1
        Next myCell
    End With
    
    'clear input cells that contain constants
    With inputWks
      On Error Resume Next
         With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
             .ClearContents
             Application.GoTo .Cells(1) ', Scroll:=True
         End With
      On Error GoTo 0
    End With
    Sheets("Input").Protect Password:="1234" '<==Protect
    ActiveSheet.Protect Password:="1234" '<==UnProtect
End Sub

[Tahiti80s]

รายละเอียดที่ต้องการครับ ขอบคุณครับ

[snasui]

ย้ายตำแหน่ง Code ที่ใช้สำหรับปลด Lock เสียใหม่มาไว้ในตำแหน่งตามตัวอย่างด่านล่างครับ

Code: Select all

'Other code
If Application.CountA(myRng) <> myRng.Cells.Count Then
        MsgBox "กรุณาใส่ข้อมูลให้ครบถ้วน"
        Exit Sub
    End If
End With

ActiveSheet.Unprotect Password:="1234" '<==UnProtect
Sheets("Input").Unprotect Password:="1234"

With historyWks
    'With .Cells(nextRow, "A")
       ' .Value = Now
        '.NumberFormat = "mm/dd/yyyy hh:mm:ss"
    'End With
    '.Cells(nextRow, "B").Value = Application.UserName
    oCol = 1
    For Each myCell In myRng.Cells
        historyWks.Cells(nextRow, oCol).Value = myCell.Value
        oCol = oCol + 1
    Next myCell
End With

'clear input cells that contain constants
With inputWks
  On Error Resume Next
     With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
         .ClearContents
         Application.GoTo .Cells(1) ', Scroll:=True
     End With
  On Error GoTo 0
End With
Sheets("Input").Protect Password:="1234" '<==Protect
ActiveSheet.Protect Password:="1234" '<==UnProtect
End Sub

[Tahiti80s]

ขอบคุณอาจารย์มากๆเลยครับ ^_^