สอบถามโค้ด VBA Protect Sheet

[Tahiti80s]

รบกวนสอบถามอาจารย์ทุกท่านครับ
เนื่องจากผมต้องการจะล๊อค Sheet แต่พอ ตั้ง คำสั่ง Yes or no พอกด No ปรากฎว่ามันคลายล๊อคเอง มีคำสั่งอะไรเพิ่มเติมหรือเปล่าครับ ที่ทำให้มันล๊อค Sheet ถาวรเลย ขอบคุณมากครับ รบกวนด้วยครับ

Code: Select all

Sub Counterdata()
   
 
    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 = "c4,c3,c5,c6,c7,c8,e17,e18,e19,e16:g16"

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

    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
    
    With inputWks
        On Error Resume Next
            Range("E16").Select
            Selection.Copy
            Range("E15").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
            Range("E16").Select
            Application.CutCopyMode = False
            
        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.Unprotect Password:="1234" '<==UnProtect

End Sub

[pongpang]

Code: Select all

[code]
Sub Counterdata()
other code
Sheets("Input").Protect Password:="1234" '<==Protect
   ' ActiveSheet.Unprotect Password:="1234" '<==UnProtect
End Sub

[/code]
คุณลอง Mark ตาม Code ข้างบน อาจจะทำได้ตามความต้องการ

[Tahiti80s]

Code: Select all

[code]
Sub Counterdata()
other code
Sheets("Input").Protect Password:="1234" '<==Protect
   ' ActiveSheet.Unprotect Password:="1234" '<==UnProtect
End Sub

[/code]
คุณลอง Mark ตาม Code ข้างบน อาจจะทำได้ตามความต้องการ

ขอบคุณครับ ทำได้ตามที่ท่านบอกครับ ติดเพียงแต่มันไม่เคลียร์ข้อมูลในเซลลให้น่ะครับ ผมงมมานานมากเลย แฮะๆ

[pongpang]

ขอบคุณครับ ทำได้ตามที่ท่านบอกครับ ติดเพียงแต่มันไม่เคลียร์ข้อมูลในเซลลให้น่ะครับ ผมงมมานานมากเลย แฮะๆ

คุณต้องให้เคลียร์ข้อมูลในชีทไหนเซลไหนบ้าง เพราะลองดูแล้ว ที่ชีท INPUT เคลียร์ข้อมูลตามต้องการแล้ว