Private Sub Worksheet_Change(ByVal Target As Range)
Set MyPlage = Range("A2:D4800")
For Each cell In MyPlage
ActiveSheet.Unprotect ("peteamy")
Select Case cell.Value
Case Is = "Peter"
cell.EntireRow.Font.ColorIndex = 3
ActiveSheet.Protect ("peteamy")
End Select
Next
Dim rw As Long
rw = Target.Row
If Range("B" & rw).Value <> "" Then
ActiveSheet.Unprotect ("peteamy")
Range("D" & rw).Locked = False
ActiveSheet.Protect ("peteamy")
'Remove locked property if B3's value is anything else or is deleted.
Else
ActiveSheet.Unprotect ("peteamy")
Range("D" & rw).Locked = True
'Optional, reprotect sheet
ActiveSheet.Protect ("peteamy")
End If
Dim Answ As String
Application.ScreenUpdating = False
Answ = MsgBox("Do you wish to confirm entry of this data?", vbOKCancel, "Confirm Change")
If Answ <> vbOK Then
Application.EnableEvents = False
Target.ClearContents 'clear contents if cancel is pressed
Application.EnableEvents = True
Exit Sub
End If
ActiveSheet.Unprotect "peteamy"
Target.Locked = True
ActiveSheet.Protect Password:="peteamy", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
Dim Sht As Worksheet
If Target.Address = "$D$4800" Then
Dim MyPath As String
Dim MyFileName As String
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path
MyFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & (" ") & Format(Now, "dd-mm-yyyy hh-mm")
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
If Not Right(MyFileName, 4) = ".xlsx" Then MyFileName = MyFileName & ".xlsx"
ActiveSheet.Copy
With ActiveWorkbook
.SaveAs Filename:= _
MyPath & MyFileName, _
CreateBackup:=False
.Close False
Application.DisplayAlerts = True
End With
ActiveWorkbook.Unprotect "peteamy"
Application.ScreenUpdating = False
Sheets("Sheet2").Visible = True
'Replace "Sheet1" with the name of the sheet to be copied.
ActiveWorkbook.Sheets("Sheet2").Copy _
after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Sheets("Sheet2").Visible = xlSheetVeryHidden
Application.DisplayAlerts = False
On Error Resume Next
ActiveSheet.Previous.Previous.Delete
ActiveWorkbook.Protect "peteamy"
End If
On Error Resume Next
Application.EnableEvents = False
If Not Target.Cells.CountLarge > 1 Then
If Not Intersect(Target, Columns(4)) Is Nothing Then
Target.Offset(1, -2).Select
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
CurrentRow = ActiveCell.Row
If CurrentRow = 1 Then Exit Sub
CurrentCol = ActiveCell.Column
If Cells(CurrentRow - 1, CurrentCol).Value = 0 Then
MsgBox ("Please Do Not Skip Rows")
ActiveCell.Offset(-1, 0).Activate
End If
Dim MyRange As Range, lr As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
Set MyRange = Range("B2:B" & lr)
For Each cell In MyRange
If cell.Value <> "" And cell.Offset(0, 2).Value = "" Then
MsgBox "Your ID Number is Required"
Application.EnableEvents = False
cell.Offset(0, 2).Select
Application.EnableEvents = True
Exit Sub
End If
Next cell
End Sub