Dim old
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Cells.CountLarge > 1 Then
MsgBox "Sorry, multiple selections are not allowed.", vbCritical
ActiveCell.Select
End If
If Target.Cells.CountLarge = 1 Then
If Not Intersect(Target, Range("A1:L1048576, N1:XFD1048576")) Is Nothing Then
old = Target.Value
End If
End If
End Sub
Private Sub CommandButton1_Click()
UpdateDataFromMasterFile
End Sub
Private Sub CommandButton2_Click()
maint_form.Show
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, c As Range
Set r = Union(Range("J6:J5000"), Range("G6:G5000"))
Set r = Intersect(Target, r)
If Not r Is Nothing Then
Application.EnableEvents = False
For Each c In r
Select Case True
Case 10 = c.Column 'J
If c.Value = "" Then
Cells(c.Row, "L").Value = ""
Cells(c.Row, "L").Locked = True
Else
Cells(c.Row, "L").Locked = False
End If
Case 7 = c.Column 'G
If c.Value = "Not Listed" Then
Cells(c.Row, "H").Locked = False
Else
Cells(c.Row, "H").Locked = True
Cells(c.Row, "H").Value = ""
End If
Case Else
End Select
Next c
End If
If Target.Cells.Count > 3 Then Exit Sub
If Not Intersect(Target, Range("C6:C5000")) Is Nothing Then
With Target(1, 3)
.Value = Date
.EntireColumn.AutoFit
End With
End If
Dim p As Range, z As Range
Set p = Range("M6:M5000")
Set p = Intersect(Target, p)
If Not p Is Nothing Then
Application.EnableEvents = False
For Each z In p
Select Case True
Case 13 = z.Column 'M
If z.Value <> "" Then
Check = MsgBox("Are your entries correct?" & vbCrLf & "After entering yes, These values CANNOT be changed.", vbYesNo + vbQuestion, "Cell Lock Notification")
If Check = vbYes Then
Target.Rows.EntireRow.Locked = True
Cells(z.Row + 1, "B").Locked = False
Cells(z.Row + 1, "C").Locked = False
Cells(z.Row + 1, "D").Locked = False
Cells(z.Row + 1, "E").Locked = False
Cells(z.Row + 1, "F").Locked = False
Cells(z.Row + 1, "G").Locked = False
Cells(z.Row + 1, "I").Locked = False
Cells(z.Row + 1, "J").Locked = False
Cells(z.Row + 1, "K").Locked = False
Cells(z.Row + 1, "M").Locked = False
If Cells(z.Row, "Q").Value <> "" Then Copyemail 'Q
If Cells(z.Row, "R").Value <> "" Then ThisWorkbook.Save 'R
With Me
.Parent.Activate
.Activate
.Range("B" & Rows.Count).End(xlUp).Offset(1).Activate
End With
Else
Cells(z.Row, "M").Value = ""
End If
End If
Case Else
End Select
Next z
End If
If Target.CountLarge > 1 Then
End If
If Not Intersect(Target, Range("A1:L1048576, N1:XFD1048576")) Is Nothing Then
If Target.Locked = True Then
With Application
.EnableEvents = False
With ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows
Sheets("Sheet2").Unprotect "password"
.Item(.Count + 1).Columns("B").Value = old
.Item(.Count + 1).Columns("C").Value = Target.Value
.Item(.Count + 1).Columns("D").Value = Environ("username")
.Item(.Count + 1).Columns("E").Value = Now
.Item(.Count + 1).Columns("F").Value = Target.Row
.Item(.Count + 1).Columns("G").Value = Target.Column
.Item(.Count + 1).Columns("H").Value = ActiveSheet.Name
End With
Application.ScreenUpdating = False
Dim outlookApp As Object
Dim myMail As Object
Set outlookApp = CreateObject("Outlook.Application")
Set myMail = outlookApp.CreateItem(0)
myMail.To = "person@acompany.net"
myMail.Subject = "Changes made"
myMail.HTMLBody = "Changes to file " & Application.ActiveWorkbook.FullName
myMail.send
.EnableEvents = True
End With
End If
End If
Sheets("Sheet2").Protect "password"
Application.EnableEvents = True
End Sub