Tracking changes not working if an entire row is deleted.

[XrayLemi]

Hello again everyone.
I have code on all the sheets in my workbook to track changes. It works perfectly IF you make a change to one cell at a time. If multiple cells or an entire row is deleted at once, and then data is re-entered one cell at a time the code does not track the changes. It should at least let me know the cell was blank before the new entry. Hopefully someone will see where the error is.

The problem code starts with the first seven lines. then continues again about eighty five lines down at : If Target.CountLarge > 1 Then

This is the code in its entirety.

Dim old
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("B6:L1048576, N6:XFD1048576")) Is Nothing Then
        old = Target.Value
    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("B6:L1048576, N6: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@company.com"
                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

Hopefully it's an easy fix.

Thank you for looking,
Jim

 

[XrayLemi]

Okay, It's been a while and no takers. So here's what I have tried since the last post.

I still cannot figure out where the problem is. So as a work around, I tried to use code that would let me know if a row was deleted. I hoped I could at least see if someone deleted an entire row in the worksheet. Even if I could not retrieve the original values. Here s the code.

This is on each sheet.

Dim What As String
If Target.Columns.Count = Columns.Count Then
 What = "Row " & Target.Row & " Deleted along with " & Target.Rows.Count - 1 & " additonal rows"
 Call DocumentChange(What)
End If

This is in a module.

Sub DocumentChange(What As String)
Dim r As Long
r = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheet2.Cells(r, 1) = What
Sheet2.Cells(r, 2) = Now
Sheet2.Cells(r, 3) = Environ("username")
Sheet2.Cells(r, 4) = ActiveSheet.Name

With Application
   .EnableEvents = False
     Application.ScreenUpdating = False
      Dim outlookApp As Object
      Dim myMail As Object
      Set outlookApp = CreateObject("Outlook.Application")
      Set myMail = outlookApp.CreateItem(0)
      myMail.To = "person@company.com"
      myMail.Subject = "Changes made"
      myMail.HTMLBody = "Changes to file " & Application.ActiveWorkbook.FullName
      myMail.send
      .EnableEvents = True
End With
End Sub

This code worked fine on a new blank workbook. But, when I added this code to the code in my "real" (test) file it did not work. No errors, just nothing happened.

 

[XrayLemi]

I thought maybe the "Exit Sub" in the third line of code may have been part of the problem. I tried to change the third line of code from...

If Target.Cells.CountLarge > 1 Then Exit Sub

to

If Target.Cells.CountLarge > 1 Then
End If

This didn't work either. I have run out of Ideas.

I can't seem to get an answer. Is my post too vague?
Thanks,
Jim

 

[XrayLemi]

I still haven't gotten an answer but maybe that's okay. It again seems to be an issue with drop down lists. If I select multiple cells that DO NOT have a drop down list and delete the data, when a new value is added, it tells me something was deleted. Even if I cannot get the old deleted value to be recorded, it records a blank value as the old value as well as the new value. However, if I select multiple cells and one of the cells has a drop down list, nothing works.

I hope that this additional information will get me the help I need.
Best,
Jim

 

[XrayLemi]

I hope someone will see this and not pass it by because they think my question has been answered. The only posts here are my own with the things I have tried and failed at.
Here is another failed attempt.

Since Drop down lists seem to be a major issue, I added the following code to remove the drop down lists after a choice is made.

Cells(z.Row, "G").Validation.Delete
Cells(z.Row, "J").Validation.Delete

I was hoping that if I removed the data validation from the cells it would remove the problem. It did not.
Hope someone has an Idea.
Jim

 

[XrayLemi]

I finally have a solution. I added the following code after the End If on line 6

If Selection.Cells.Count > 1 Then 
        MsgBox "Sorry, multiple selections are not allowed.", vbCritical 
        ActiveCell.Select 
        Exit Sub 
    End If

Now you can only make a change to a single cell at a time. No deleting an entire row. No deleting multiple cells. Any single cell changes that shouldn't happen will be recorded!