KHOÁ CÁC Ô ĐÃ NHẬP DỮ LIỆU TRÊN EXCEL

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Cột N của sheet"TON KHO" vẫn hiện công thức nè anh.
 

File đính kèm

  • QL THIẾT BỊ- VẬT TƯ_FIX.xlsm
    151.3 KB · Đọc: 4
@hungvu0106 Bạn có thể sử dụng hàm LockCells dưới đây

Sử dụng:

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
10 là số giây, là khoảng thời gian Delay để khóa ô

Gõ thêm "_" thành LockCells_ để bỏ thực thi.

Mã dưới đây đặt trong Module mới
JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'

Option Explicit
Option Compare Text
Private Const projectUDFName = "LockCells"
Private Const projectUDFFileName = "LockCells"
Private Const projectUDFVersion = "1.0"

#If VBA7 = 0 Then
  Public Enum LongLong:[_]:End Enum
  Public Enum LongPtr:[_]:End Enum
#End If

#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If

Public Enum ValueLockSettings
  VDSLockRange = 1
End Enum

Public Type TypeArguments
  Action As Long
  direction As Long
  timer As Single
  ThisCell As Object
  Fx As String
  Target As Range
  address As String
  value As Variant
  SheetPW As String
End Type

Private Const n_ = vbNullString
Private Works() As TypeArguments

Function LockCells_(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells_ = ""
End Function
Function LockCells(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells = ""
  Call LockValueCommand(VDSLockRange, cells, sheetPassword, DelaySeconds)
End Function

Private Function LockValueCommand(direction&, ParamArray arguments())
  On Error Resume Next
  Dim r As Object
  Set r = Application.ThisCell: If r Is Nothing Then Exit Function
  Dim k%, i%, j%, adr$, f$, w As TypeArguments, n As Boolean
  f = r.formula
  adr = r.address(0, 0,,1)
  k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k)
adr:
  With Works(k): .Action = 1: Set .ThisCell = r: .address = adr: .Fx = f
    .direction = direction: .timer = timer
    Select Case direction
    Case VDSLockRange:: Set .Target = arguments(0): .SheetPW = arguments(1)
    End Select
    Call LockValue_Timer(arguments(2) * 1000)
  End With
End Function

Private Sub LockValue_Timer(Optional ByVal timer&)
  If timer < 0 Then timer = 0
  Call SetTimer(Application.hwnd, 444110, timer, AddressOf LockValue_callback)
End Sub

Private Sub LockValue_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Call KillTimer(hwnd, idEvent)
  LockValue_working
End Sub
 
Private Sub LockValue_working()
  On Error Resume Next
  Dim aa, UA%, i%, Sh As Object, w, lr&, rg, rg2 As Object
  Dim a As Object, b As TypeArguments, su As Boolean, ac As Boolean, ee As Boolean
  UA = UBound(Works)
  If UA = 0 Then Exit Sub

  For i = 1 To UA
    b = Works(i)
    With Works(i)
      Select Case .Action
      Case 1
        .Action = 2
        'GoSub a
        Set Sh = .Target.Parent
        If Sh.ProtectContents Then
          Err.Clear: Sh.Unprotect password:=.SheetPW: If Err Then GoTo n
        End If
        .ThisCell.FormulaHidden = True
        .ThisCell.Locked = True
        Select Case .direction
        Case VDSLockRange:
          .Target.FormulaHidden = True
          .Target.Locked = True
          Err.Clear: Set rg2 = .Target.SpecialCells(xlCellTypeBlanks)
          If Not rg2 Is Nothing And Err = 0 Then rg2.Locked = False: rg2.FormulaHidden = False
        End Select
s:
        If Not Sh.ProtectContents Then Sh.Protect password:=.SheetPW
      End Select
    End With
n:
  Next
E:
  Erase Works
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac And a.Calculation <> xlCalculationAutomatic Then a.Calculation = xlCalculationAutomatic
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
  End If
Exit Sub
a:
  If a Is Nothing Then
    Set a = Application
    su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
    ee = a.EnableEvents: If ee Then a.EnableEvents = False
    ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
  End If
Return
End Sub


Mã dưới đây đặt trong mã ThisWorkbook

JavaScript:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Sh.ProtectContents Then
    On Error Resume Next
    If Target.Locked Then
      Cancel = True
      Application.Dialogs(xlDialogProtectDocument).Show
    End If
  End If
End Sub
Mình cảm ơn bạn. Mình sẽ thử
@hungvu0106 Bạn có thể sử dụng hàm LockCells dưới đây

Sử dụng:

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
10 là số giây, là khoảng thời gian Delay để khóa ô

Gõ thêm "_" thành LockCells_ để bỏ thực thi.

Mã dưới đây đặt trong Module mới
JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'

Option Explicit
Option Compare Text
Private Const projectUDFName = "LockCells"
Private Const projectUDFFileName = "LockCells"
Private Const projectUDFVersion = "1.0"

#If VBA7 = 0 Then
  Public Enum LongLong:[_]:End Enum
  Public Enum LongPtr:[_]:End Enum
#End If

#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If

Public Enum ValueLockSettings
  VDSLockRange = 1
End Enum

Public Type TypeArguments
  Action As Long
  direction As Long
  timer As Single
  ThisCell As Object
  Fx As String
  Target As Range
  address As String
  value As Variant
  SheetPW As String
End Type

Private Const n_ = vbNullString
Private Works() As TypeArguments

Function LockCells_(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells_ = ""
End Function
Function LockCells(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells = ""
  Call LockValueCommand(VDSLockRange, cells, sheetPassword, DelaySeconds)
End Function

Private Function LockValueCommand(direction&, ParamArray arguments())
  On Error Resume Next
  Dim r As Object
  Set r = Application.ThisCell: If r Is Nothing Then Exit Function
  Dim k%, i%, j%, adr$, f$, w As TypeArguments, n As Boolean
  f = r.formula
  adr = r.address(0, 0,,1)
  k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k)
adr:
  With Works(k): .Action = 1: Set .ThisCell = r: .address = adr: .Fx = f
    .direction = direction: .timer = timer
    Select Case direction
    Case VDSLockRange:: Set .Target = arguments(0): .SheetPW = arguments(1)
    End Select
    Call LockValue_Timer(arguments(2) * 1000)
  End With
End Function

Private Sub LockValue_Timer(Optional ByVal timer&)
  If timer < 0 Then timer = 0
  Call SetTimer(Application.hwnd, 444110, timer, AddressOf LockValue_callback)
End Sub

Private Sub LockValue_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Call KillTimer(hwnd, idEvent)
  LockValue_working
End Sub
 
Private Sub LockValue_working()
  On Error Resume Next
  Dim aa, UA%, i%, Sh As Object, w, lr&, rg, rg2 As Object
  Dim a As Object, b As TypeArguments, su As Boolean, ac As Boolean, ee As Boolean
  UA = UBound(Works)
  If UA = 0 Then Exit Sub

  For i = 1 To UA
    b = Works(i)
    With Works(i)
      Select Case .Action
      Case 1
        .Action = 2
        'GoSub a
        Set Sh = .Target.Parent
        If Sh.ProtectContents Then
          Err.Clear: Sh.Unprotect password:=.SheetPW: If Err Then GoTo n
        End If
        .ThisCell.FormulaHidden = True
        .ThisCell.Locked = True
        Select Case .direction
        Case VDSLockRange:
          .Target.FormulaHidden = True
          .Target.Locked = True
          Err.Clear: Set rg2 = .Target.SpecialCells(xlCellTypeBlanks)
          If Not rg2 Is Nothing And Err = 0 Then rg2.Locked = False: rg2.FormulaHidden = False
        End Select
s:
        If Not Sh.ProtectContents Then Sh.Protect password:=.SheetPW
      End Select
    End With
n:
  Next
E:
  Erase Works
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac And a.Calculation <> xlCalculationAutomatic Then a.Calculation = xlCalculationAutomatic
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
  End If
Exit Sub
a:
  If a Is Nothing Then
    Set a = Application
    su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
    ee = a.EnableEvents: If ee Then a.EnableEvents = False
    ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
  End If
Return
End Sub


Mã dưới đây đặt trong mã ThisWorkbook

JavaScript:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Sh.ProtectContents Then
    On Error Resume Next
    If Target.Locked Then
      Cancel = True
      Application.Dialogs(xlDialogProtectDocument).Show
    End If
  End If
End Sub
Mình mới dùng thử cách code này nhờ bạn xem giúp. Sau 5s nó tự động khoá cả ô có dữ liệu và ô chưa có dữ liệu có cách nào chỉ khoá ô có dữ liệu còn ô chưa có thì vẫn chọn bth được k ạ
@hungvu0106 Trong tệp của bạn không có mã như tôi đã hướng dẫn
Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
2 cái này mình không rõ là sẽ điều chỉnh ở ô nào.
Bạn xem lại bên máy của bạn - Tôi đã tes bên máy của tôi Office 2007 đến Office 2010 vẫn chạy tốt mà
Bạn thử xóa code cũ đi xem sao

Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Bài đã được tự động gộp:


Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Bài đã được tự động gộp:


Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Mình làm thử được rồi bạn. Nhưng cho mình hỏi thêm chút ở cái dòng cuối cùng khi mình nhập số lượng thì nó lại không khoá được(nhưng cột ở trên thì nó khoá). có cách nào khắc phục được k. Bạn xem file giúp mình với. Minh chân thành cảm ơn bạn
Bài đã được tự động gộp:

@hungvu0106 Bạn có thể sử dụng hàm LockCells dưới đây

Sử dụng:

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
10 là số giây, là khoảng thời gian Delay để khóa ô

Gõ thêm "_" thành LockCells_ để bỏ thực thi.

Mã dưới đây đặt trong Module mới
JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'

Option Explicit
Option Compare Text
Private Const projectUDFName = "LockCells"
Private Const projectUDFFileName = "LockCells"
Private Const projectUDFVersion = "1.0"

#If VBA7 = 0 Then
  Public Enum LongLong:[_]:End Enum
  Public Enum LongPtr:[_]:End Enum
#End If

#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If

Public Enum ValueLockSettings
  VDSLockRange = 1
End Enum

Public Type TypeArguments
  Action As Long
  direction As Long
  timer As Single
  ThisCell As Object
  Fx As String
  Target As Range
  address As String
  value As Variant
  SheetPW As String
End Type

Private Const n_ = vbNullString
Private Works() As TypeArguments

Function LockCells_(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells_ = ""
End Function
Function LockCells(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells = ""
  Call LockValueCommand(VDSLockRange, cells, sheetPassword, DelaySeconds)
End Function

Private Function LockValueCommand(direction&, ParamArray arguments())
  On Error Resume Next
  Dim r As Object
  Set r = Application.ThisCell: If r Is Nothing Then Exit Function
  Dim k%, i%, j%, adr$, f$, w As TypeArguments, n As Boolean
  f = r.formula
  adr = r.address(0, 0,,1)
  k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k)
adr:
  With Works(k): .Action = 1: Set .ThisCell = r: .address = adr: .Fx = f
    .direction = direction: .timer = timer
    Select Case direction
    Case VDSLockRange:: Set .Target = arguments(0): .SheetPW = arguments(1)
    End Select
    Call LockValue_Timer(arguments(2) * 1000)
  End With
End Function

Private Sub LockValue_Timer(Optional ByVal timer&)
  If timer < 0 Then timer = 0
  Call SetTimer(Application.hwnd, 444110, timer, AddressOf LockValue_callback)
End Sub

Private Sub LockValue_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Call KillTimer(hwnd, idEvent)
  LockValue_working
End Sub
 
Private Sub LockValue_working()
  On Error Resume Next
  Dim aa, UA%, i%, Sh As Object, w, lr&, rg, rg2 As Object
  Dim a As Object, b As TypeArguments, su As Boolean, ac As Boolean, ee As Boolean
  UA = UBound(Works)
  If UA = 0 Then Exit Sub

  For i = 1 To UA
    b = Works(i)
    With Works(i)
      Select Case .Action
      Case 1
        .Action = 2
        'GoSub a
        Set Sh = .Target.Parent
        If Sh.ProtectContents Then
          Err.Clear: Sh.Unprotect password:=.SheetPW: If Err Then GoTo n
        End If
        .ThisCell.FormulaHidden = True
        .ThisCell.Locked = True
        Select Case .direction
        Case VDSLockRange:
          .Target.FormulaHidden = True
          .Target.Locked = True
          Err.Clear: Set rg2 = .Target.SpecialCells(xlCellTypeBlanks)
          If Not rg2 Is Nothing And Err = 0 Then rg2.Locked = False: rg2.FormulaHidden = False
        End Select
s:
        If Not Sh.ProtectContents Then Sh.Protect password:=.SheetPW
      End Select
    End With
n:
  Next
E:
  Erase Works
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac And a.Calculation <> xlCalculationAutomatic Then a.Calculation = xlCalculationAutomatic
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
  End If
Exit Sub
a:
  If a Is Nothing Then
    Set a = Application
    su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
    ee = a.EnableEvents: If ee Then a.EnableEvents = False
    ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
  End If
Return
End Sub


Mã dưới đây đặt trong mã ThisWorkbook

JavaScript:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Sh.ProtectContents Then
    On Error Resume Next
    If Target.Locked Then
      Cancel = True
      Application.Dialogs(xlDialogProtectDocument).Show
    End If
  End If
End Sub
Mình cảm ơn bạn. Mình sẽ thử
@hungvu0106 Bạn có thể sử dụng hàm LockCells dưới đây

Sử dụng:

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
10 là số giây, là khoảng thời gian Delay để khóa ô

Gõ thêm "_" thành LockCells_ để bỏ thực thi.

Mã dưới đây đặt trong Module mới
JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'

Option Explicit
Option Compare Text
Private Const projectUDFName = "LockCells"
Private Const projectUDFFileName = "LockCells"
Private Const projectUDFVersion = "1.0"

#If VBA7 = 0 Then
  Public Enum LongLong:[_]:End Enum
  Public Enum LongPtr:[_]:End Enum
#End If

#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If

Public Enum ValueLockSettings
  VDSLockRange = 1
End Enum

Public Type TypeArguments
  Action As Long
  direction As Long
  timer As Single
  ThisCell As Object
  Fx As String
  Target As Range
  address As String
  value As Variant
  SheetPW As String
End Type

Private Const n_ = vbNullString
Private Works() As TypeArguments

Function LockCells_(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells_ = ""
End Function
Function LockCells(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells = ""
  Call LockValueCommand(VDSLockRange, cells, sheetPassword, DelaySeconds)
End Function

Private Function LockValueCommand(direction&, ParamArray arguments())
  On Error Resume Next
  Dim r As Object
  Set r = Application.ThisCell: If r Is Nothing Then Exit Function
  Dim k%, i%, j%, adr$, f$, w As TypeArguments, n As Boolean
  f = r.formula
  adr = r.address(0, 0,,1)
  k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k)
adr:
  With Works(k): .Action = 1: Set .ThisCell = r: .address = adr: .Fx = f
    .direction = direction: .timer = timer
    Select Case direction
    Case VDSLockRange:: Set .Target = arguments(0): .SheetPW = arguments(1)
    End Select
    Call LockValue_Timer(arguments(2) * 1000)
  End With
End Function

Private Sub LockValue_Timer(Optional ByVal timer&)
  If timer < 0 Then timer = 0
  Call SetTimer(Application.hwnd, 444110, timer, AddressOf LockValue_callback)
End Sub

Private Sub LockValue_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Call KillTimer(hwnd, idEvent)
  LockValue_working
End Sub
 
Private Sub LockValue_working()
  On Error Resume Next
  Dim aa, UA%, i%, Sh As Object, w, lr&, rg, rg2 As Object
  Dim a As Object, b As TypeArguments, su As Boolean, ac As Boolean, ee As Boolean
  UA = UBound(Works)
  If UA = 0 Then Exit Sub

  For i = 1 To UA
    b = Works(i)
    With Works(i)
      Select Case .Action
      Case 1
        .Action = 2
        'GoSub a
        Set Sh = .Target.Parent
        If Sh.ProtectContents Then
          Err.Clear: Sh.Unprotect password:=.SheetPW: If Err Then GoTo n
        End If
        .ThisCell.FormulaHidden = True
        .ThisCell.Locked = True
        Select Case .direction
        Case VDSLockRange:
          .Target.FormulaHidden = True
          .Target.Locked = True
          Err.Clear: Set rg2 = .Target.SpecialCells(xlCellTypeBlanks)
          If Not rg2 Is Nothing And Err = 0 Then rg2.Locked = False: rg2.FormulaHidden = False
        End Select
s:
        If Not Sh.ProtectContents Then Sh.Protect password:=.SheetPW
      End Select
    End With
n:
  Next
E:
  Erase Works
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac And a.Calculation <> xlCalculationAutomatic Then a.Calculation = xlCalculationAutomatic
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
  End If
Exit Sub
a:
  If a Is Nothing Then
    Set a = Application
    su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
    ee = a.EnableEvents: If ee Then a.EnableEvents = False
    ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
  End If
Return
End Sub


Mã dưới đây đặt trong mã ThisWorkbook

JavaScript:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Sh.ProtectContents Then
    On Error Resume Next
    If Target.Locked Then
      Cancel = True
      Application.Dialogs(xlDialogProtectDocument).Show
    End If
  End If
End Sub
Mình mới dùng thử cách code này nhờ bạn xem giúp. Sau 5s nó tự động khoá cả ô có dữ liệu và ô chưa có dữ liệu có cách nào chỉ khoá ô có dữ liệu còn ô chưa có thì vẫn chọn bth được k ạ
@hungvu0106 Trong tệp của bạn không có mã như tôi đã hướng dẫn
Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
2 cái này mình không rõ là sẽ điều chỉnh ở ô nào.
Bạn xem lại bên máy của bạn - Tôi đã tes bên máy của tôi Office 2007 đến Office 2010 vẫn chạy tốt mà
Bạn thử xóa code cũ đi xem sao

Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Bài đã được tự động gộp:


Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Bài đã được tự động gộp:


Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Mình làm thử được rồi bạn. Nhưng cho mình hỏi thêm chút ở cái dòng cuối cùng khi mình nhập số lượng thì nó lại không khoá được(nhưng cột ở trên thì nó khoá). có cách nào khắc phục được k. Bạn xem file giúp mình với. Minh chân thành cảm ơn bạn
 

File đính kèm

  • QL THIẾT BỊ- VẬT TƯ_FIX.xlsm
    151.5 KB · Đọc: 3
Mình cảm ơn bạn. Mình sẽ thử

Mình mới dùng thử cách code này nhờ bạn xem giúp. Sau 5s nó tự động khoá cả ô có dữ liệu và ô chưa có dữ liệu có cách nào chỉ khoá ô có dữ liệu còn ô chưa có thì vẫn chọn bth được k ạ

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
2 cái này mình không rõ là sẽ điều chỉnh ở ô nào.



Mình làm thử được rồi bạn. Nhưng cho mình hỏi thêm chút ở cái dòng cuối cùng khi mình nhập số lượng thì nó lại không khoá được(nhưng cột ở trên thì nó khoá). có cách nào khắc phục được k. Bạn xem file giúp mình với. Minh chân thành cảm ơn bạn
Bài đã được tự động gộp:


Mình cảm ơn bạn. Mình sẽ thử

Mình mới dùng thử cách code này nhờ bạn xem giúp. Sau 5s nó tự động khoá cả ô có dữ liệu và ô chưa có dữ liệu có cách nào chỉ khoá ô có dữ liệu còn ô chưa có thì vẫn chọn bth được k ạ

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
2 cái này mình không rõ là sẽ điều chỉnh ở ô nào.



Mình làm thử được rồi bạn. Nhưng cho mình hỏi thêm chút ở cái dòng cuối cùng khi mình nhập số lượng thì nó lại không khoá được(nhưng cột ở trên thì nó khoá). có cách nào khắc phục được k. Bạn xem file giúp mình với. Minh chân thành cảm ơn bạn
Bạn không phải bị riêng G13 đâu mà là cả G6:G13, bạn thử clear data từ G6:G13 nhập lại xem code có chạy để khóa cells k ?
 
@hungvu0106 Bạn có thể sử dụng hàm LockCells dưới đây

Sử dụng:

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
10 là số giây, là khoảng thời gian Delay để khóa ô

Gõ thêm "_" thành LockCells_ để bỏ thực thi.

Mã dưới đây đặt trong Module mới
JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'

Option Explicit
Option Compare Text
Private Const projectUDFName = "LockCells"
Private Const projectUDFFileName = "LockCells"
Private Const projectUDFVersion = "1.0"

#If VBA7 = 0 Then
  Public Enum LongLong:[_]:End Enum
  Public Enum LongPtr:[_]:End Enum
#End If

#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If

Public Enum ValueLockSettings
  VDSLockRange = 1
End Enum

Public Type TypeArguments
  Action As Long
  direction As Long
  timer As Single
  ThisCell As Object
  Fx As String
  Target As Range
  address As String
  value As Variant
  SheetPW As String
End Type

Private Const n_ = vbNullString
Private Works() As TypeArguments

Function LockCells_(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells_ = ""
End Function
Function LockCells(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells = ""
  Call LockValueCommand(VDSLockRange, cells, sheetPassword, DelaySeconds)
End Function

Private Function LockValueCommand(direction&, ParamArray arguments())
  On Error Resume Next
  Dim r As Object
  Set r = Application.ThisCell: If r Is Nothing Then Exit Function
  Dim k%, i%, j%, adr$, f$, w As TypeArguments, n As Boolean
  f = r.formula
  adr = r.address(0, 0,,1)
  k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k)
adr:
  With Works(k): .Action = 1: Set .ThisCell = r: .address = adr: .Fx = f
    .direction = direction: .timer = timer
    Select Case direction
    Case VDSLockRange:: Set .Target = arguments(0): .SheetPW = arguments(1)
    End Select
    Call LockValue_Timer(arguments(2) * 1000)
  End With
End Function

Private Sub LockValue_Timer(Optional ByVal timer&)
  If timer < 0 Then timer = 0
  Call SetTimer(Application.hwnd, 444110, timer, AddressOf LockValue_callback)
End Sub

Private Sub LockValue_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Call KillTimer(hwnd, idEvent)
  LockValue_working
End Sub
 
Private Sub LockValue_working()
  On Error Resume Next
  Dim aa, UA%, i%, Sh As Object, w, lr&, rg, rg2 As Object
  Dim a As Object, b As TypeArguments, su As Boolean, ac As Boolean, ee As Boolean
  UA = UBound(Works)
  If UA = 0 Then Exit Sub

  For i = 1 To UA
    b = Works(i)
    With Works(i)
      Select Case .Action
      Case 1
        .Action = 2
        'GoSub a
        Set Sh = .Target.Parent
        If Sh.ProtectContents Then
          Err.Clear: Sh.Unprotect password:=.SheetPW: If Err Then GoTo n
        End If
        .ThisCell.FormulaHidden = True
        .ThisCell.Locked = True
        Select Case .direction
        Case VDSLockRange:
          .Target.FormulaHidden = True
          .Target.Locked = True
          Err.Clear: Set rg2 = .Target.SpecialCells(xlCellTypeBlanks)
          If Not rg2 Is Nothing And Err = 0 Then rg2.Locked = False: rg2.FormulaHidden = False
        End Select
s:
        If Not Sh.ProtectContents Then Sh.Protect password:=.SheetPW
      End Select
    End With
n:
  Next
E:
  Erase Works
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac And a.Calculation <> xlCalculationAutomatic Then a.Calculation = xlCalculationAutomatic
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
  End If
Exit Sub
a:
  If a Is Nothing Then
    Set a = Application
    su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
    ee = a.EnableEvents: If ee Then a.EnableEvents = False
    ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
  End If
Return
End Sub


Mã dưới đây đặt trong mã ThisWorkbook

JavaScript:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Sh.ProtectContents Then
    On Error Resume Next
    If Target.Locked Then
      Cancel = True
      Application.Dialogs(xlDialogProtectDocument).Show
    End If
  End If
End Sub
Mình cảm ơn bạn. Mình sẽ thử
@hungvu0106 Bạn có thể sử dụng hàm LockCells dưới đây

Sử dụng:

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
10 là số giây, là khoảng thời gian Delay để khóa ô

Gõ thêm "_" thành LockCells_ để bỏ thực thi.

Mã dưới đây đặt trong Module mới
JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'

Option Explicit
Option Compare Text
Private Const projectUDFName = "LockCells"
Private Const projectUDFFileName = "LockCells"
Private Const projectUDFVersion = "1.0"

#If VBA7 = 0 Then
  Public Enum LongLong:[_]:End Enum
  Public Enum LongPtr:[_]:End Enum
#End If

#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If

Public Enum ValueLockSettings
  VDSLockRange = 1
End Enum

Public Type TypeArguments
  Action As Long
  direction As Long
  timer As Single
  ThisCell As Object
  Fx As String
  Target As Range
  address As String
  value As Variant
  SheetPW As String
End Type

Private Const n_ = vbNullString
Private Works() As TypeArguments

Function LockCells_(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells_ = ""
End Function
Function LockCells(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
  LockCells = ""
  Call LockValueCommand(VDSLockRange, cells, sheetPassword, DelaySeconds)
End Function

Private Function LockValueCommand(direction&, ParamArray arguments())
  On Error Resume Next
  Dim r As Object
  Set r = Application.ThisCell: If r Is Nothing Then Exit Function
  Dim k%, i%, j%, adr$, f$, w As TypeArguments, n As Boolean
  f = r.formula
  adr = r.address(0, 0,,1)
  k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k)
adr:
  With Works(k): .Action = 1: Set .ThisCell = r: .address = adr: .Fx = f
    .direction = direction: .timer = timer
    Select Case direction
    Case VDSLockRange:: Set .Target = arguments(0): .SheetPW = arguments(1)
    End Select
    Call LockValue_Timer(arguments(2) * 1000)
  End With
End Function

Private Sub LockValue_Timer(Optional ByVal timer&)
  If timer < 0 Then timer = 0
  Call SetTimer(Application.hwnd, 444110, timer, AddressOf LockValue_callback)
End Sub

Private Sub LockValue_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Call KillTimer(hwnd, idEvent)
  LockValue_working
End Sub
 
Private Sub LockValue_working()
  On Error Resume Next
  Dim aa, UA%, i%, Sh As Object, w, lr&, rg, rg2 As Object
  Dim a As Object, b As TypeArguments, su As Boolean, ac As Boolean, ee As Boolean
  UA = UBound(Works)
  If UA = 0 Then Exit Sub

  For i = 1 To UA
    b = Works(i)
    With Works(i)
      Select Case .Action
      Case 1
        .Action = 2
        'GoSub a
        Set Sh = .Target.Parent
        If Sh.ProtectContents Then
          Err.Clear: Sh.Unprotect password:=.SheetPW: If Err Then GoTo n
        End If
        .ThisCell.FormulaHidden = True
        .ThisCell.Locked = True
        Select Case .direction
        Case VDSLockRange:
          .Target.FormulaHidden = True
          .Target.Locked = True
          Err.Clear: Set rg2 = .Target.SpecialCells(xlCellTypeBlanks)
          If Not rg2 Is Nothing And Err = 0 Then rg2.Locked = False: rg2.FormulaHidden = False
        End Select
s:
        If Not Sh.ProtectContents Then Sh.Protect password:=.SheetPW
      End Select
    End With
n:
  Next
E:
  Erase Works
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac And a.Calculation <> xlCalculationAutomatic Then a.Calculation = xlCalculationAutomatic
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
  End If
Exit Sub
a:
  If a Is Nothing Then
    Set a = Application
    su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
    ee = a.EnableEvents: If ee Then a.EnableEvents = False
    ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
  End If
Return
End Sub


Mã dưới đây đặt trong mã ThisWorkbook

JavaScript:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Sh.ProtectContents Then
    On Error Resume Next
    If Target.Locked Then
      Cancel = True
      Application.Dialogs(xlDialogProtectDocument).Show
    End If
  End If
End Sub
Mình mới dùng thử cách code này nhờ bạn xem giúp. Sau 5s nó tự động khoá cả ô có dữ liệu và ô chưa có dữ liệu có cách nào chỉ khoá ô có dữ liệu còn ô chưa có thì vẫn chọn bth được k ạ
@hungvu0106 Trong tệp của bạn không có mã như tôi đã hướng dẫn
Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
2 cái này mình không rõ là sẽ điều chỉnh ở ô nào.
Bạn xem lại bên máy của bạn - Tôi đã tes bên máy của tôi Office 2007 đến Office 2010 vẫn chạy tốt mà
Bạn thử xóa code cũ đi xem sao

Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Bài đã được tự động gộp:


Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Bài đã được tự động gộp:


Bạn lấy File bài #11 về chạy xem sao nào ???

Bạn xem đánh dấu tích vào như ảnh dưới nhé
Mình làm thử được rồi bạn. Nhưng cho mình hỏi thêm chút ở cái dòng cuối cùng khi mình nhập số lượng thì nó lại không khoá được(nhưng cột ở trên thì nó khoá). có cách nào khắc phục được k. Bạn xem file giúp mình với. Minh chân thành cảm ơn bạn
Bạn không phải bị riêng G13 đâu mà là cả G6:G13, bạn thử clear data từ G6:G13 nhập lại xem code có chạy để khóa cells k ?
Mình cảm ơn bạn. Mình đã kiểm tra lại ở cột G6:G13 nó vẫn khoá bình thường bạn ạ, Chỉ có G13 là nó không khoá được nhưng mình nhập SỐ LƯỢNG ở G14 thì G13 nó sẽ khoá. Mình không biết làm sao để nó khoá được hết.
 
Mình cảm ơn bạn. Mình sẽ thử

Mình mới dùng thử cách code này nhờ bạn xem giúp. Sau 5s nó tự động khoá cả ô có dữ liệu và ô chưa có dữ liệu có cách nào chỉ khoá ô có dữ liệu còn ô chưa có thì vẫn chọn bth được k ạ

Với vùng ô A1:A100 sau khi nhập sau 10 giây sẽ khóa ô đã nhập
Gõ hàm =LockCells(A1:A100, "Mật Khẩu Trang tính", 10)
2 cái này mình không rõ là sẽ điều chỉnh ở ô nào.



Mình làm thử được rồi bạn. Nhưng cho mình hỏi thêm chút ở cái dòng cuối cùng khi mình nhập số lượng thì nó lại không khoá được(nhưng cột ở trên thì nó khoá). có cách nào khắc phục được k. Bạn xem file giúp mình với. Minh chân thành cảm ơn bạn

Mình cảm ơn bạn. Mình đã kiểm tra lại ở cột G6:G13 nó vẫn khoá bình thường bạn ạ, Chỉ có G13 là nó không khoá được nhưng mình nhập SỐ LƯỢNG ở G14 thì G13 nó sẽ khoá. Mình không biết làm sao để nó khoá được hết.
Thế thì lạ nhỉ, bên mình thì clear data thử lại từ G6:G13 thì nó không khóa, không biết có phải tại win k mình dùng win 7 và 365.
 
Web KT
Back
Top Bottom