Hi
I have a spreadsheet for recording issues, when complete we update cell in column "M", VB will then set each cell for the row to locked. this then prevents the row from being edited, the rest remain editable.
however i am now finding that cells that start off with Locked un-ticked are now ticked an now have to unprotect the sheet.
I have checked through the VB but cannot see why it is doing this, code below.
hope someone can see where i have gone wrong.
Many Thanks
I have a spreadsheet for recording issues, when complete we update cell in column "M", VB will then set each cell for the row to locked. this then prevents the row from being edited, the rest remain editable.
however i am now finding that cells that start off with Locked un-ticked are now ticked an now have to unprotect the sheet.
I have checked through the VB but cannot see why it is doing this, code below.
hope someone can see where i have gone wrong.
Many Thanks
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
'have something to so first unprotect sheet
ActiveSheet.Unprotect ("password")
' make sure the "Y" is changed to upper case in columns "M" (keeps it neat)
If Not (Application.Intersect(Target, Range("M7:M306")) _
Is Nothing) Then
With Target
If Not .HasFormula Then
Application.EnableEvents = False
.Value = UCase(.Value)
.Offset(0, 1).Value = Now
.Offset(0, 2).Value = Environ("username")
Application.EnableEvents = True
End If
End With
End If
Dim rowId As Long
'check in the area that was change contains at least one cell from M1:M1005 or Z1:W306
If (Intersect(Target, Union(Range(Cells(1, "M"), Cells(306, "M")), Range(Cells(1, "Z"), Cells(306, "Z")))) Is Nothing) Then
' no match, so nothing to do
Exit Sub
End If
'have something to so first unprotect sheet
ActiveSheet.Unprotect ("password")
'the email code may need to go in between this section
'for each row that have been modified, check
For Each Row In Target.Rows
rowId = Row.Row
'check lock/unlock cells A:M
Range(Cells(rowId, "A"), Cells(rowId, "M")).Locked = (Cells(rowId, "M") = "Y")
'check lock/unlock cells N:W
Range(Cells(rowId, "N"), Cells(rowId, "Y")).Locked = (Cells(rowId, "M") = "Y")
Next
ActiveSheet.Protect ("password"), DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimit As Double
Dim MyDate As Date
NotSentMsg = " "
SentMsg = "Sent"
'Above the MyLimit value it will run the macro
MyLimit = 2
'Un lock Sheet (add a password here)
ActiveSheet.Unprotect ("password")
'Set the range with Formulas that you want to check
Set FormulaRange = Me.Range("W7:W306")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = "error no numeric value"
Else
If .Value > MyLimit Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
Else
MyMsg = NotSentMsg
End If
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
If MyMsg = "Sent" And .Offset(0, 2).Value = "" Then
.Offset(0, 2).Value = Now
End If
Application.EnableEvents = True
End With
Next FormulaCell
'Lock Spreadsheet (add same password as above)
ActiveSheet.Protect ("password"), DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
ActiveSheet.EnableSelection = xlUnlockedCells
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
Application.ScreenUpdating = True
End Sub
