Nhờ sửa code sự kiện (Một vùng Cells từ A8-AM160) chạy rất chậm

[le_vis]

Tôi có sử dụng đoạn code sự kiện của 01 bạn trên GPE (Lâu rồi không nhớ được của ai nữa); Đồng thời biến tấu đi với mục đích : Tự động khóa tạm thời những Cell khi cập nhật dữ liệu vào trong vùng từ A8 – AM160 của SheetDM_hang mà vẫn đảm bảo được một số chức năng trong quá trình sử dụng như Format Cells, Edit Obejects …….

Nhưng khi code chạy: Nó vẫn thực hiện loát kiểm tra cả những vùng ngoài vùng từ A8 – AM160 nên chạy rất lâu _ Kính nhờ các bạn xem sửa giúp sao cho chạy nhanh hơn

Trân trọng cảm ơn !

Code như sau :

Private Sub Worksheet_Change(ByVal Target As Range)

Dim A8 As Range

Sheets("DM_hang").Unprotect ""

For Each A8 In Range("A8:AM160")

A8.Locked = (A8 <> "")

Next

Sheets("DM_hang").Protect "", AllowFiltering:=True, AllowFormattingColumns:=True, _

AllowFormattingRows:=True, AllowFormattingCells:=True, DrawingObjects:=False

End Sub

Kính mong nhận được sự giúp đỡ của quý thầy cô và các bạn

 

[befaint]

Private Sub Worksheet_Change(ByVal Target As Range)
const sRangeChange = "A8:AM160"
if intersect(Target, Range(sRangeChange)) is nothing then exit sub
Dim cell_ As Range

Sheets("DM_hang").Unprotect ""

For Each cell_ In Range("A8:AM160")

cell_ .Locked = (vba.len(cell_.value)>0)

Next cell_

Sheets("DM_hang").Protect "", AllowFiltering:=True, AllowFormattingColumns:=True, _

AllowFormattingRows:=True, AllowFormattingCells:=True, DrawingObjects:=False

End Sub

 

[Phuocam]

nên chạy rất lâu

Thủ thêm mấy dòng này vào phía trên:

Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False


và mấy dòng này vào phía dưới:

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

 

[HeSanbi]

Bạn vận dụng thế này:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim s As Range
  Set s = Range("A8:AM160")
  If Intersect(Target, s) Is Nothing Then Exit Sub
  s.Parent.Unprotect ""
  s.Locked = True
  On Error Resume Next
  s.SpecialCells(xlCellTypeBlanks).Locked = False
  s.Parent.Protect "", AllowFiltering:=True, AllowFormattingColumns:=True, _
  AllowFormattingRows:=True, AllowFormattingCells:=True, DrawingObjects:=False
End Sub

 

[le_vis]

Thủ thêm mấy dòng này vào phía trên:

Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False


và mấy dòng này vào phía dưới:

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Bạn vận dụng thế này:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim s As Range
  Set s = Range("A8:AM160")
  If Intersect(Target, s) Is Nothing Then Exit Sub
  s.Parent.Unprotect ""
  s.Locked = True
  On Error Resume Next
  s.SpecialCells(xlCellTypeBlanks).Locked = False
  s.Parent.Protect "", AllowFiltering:=True, AllowFormattingColumns:=True, _
  AllowFormattingRows:=True, AllowFormattingCells:=True, DrawingObjects:=False
End Sub

Xin cảm ơn các bạn nhiều. Code chạy tốt