Copy Cell changes to a different sheet.

X

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
153
Office Version
  1. 365
Platform
  1. Windows
Hope you all are healthy and safe.
Once again I am at your mercy.
I am trying to log changes to specific cells on a spreadsheet. The cells I am trying to log changes to have their attributes set to locked. When the changes are made the sheet will be password unprotected. I only want the code to change the cells whos properties are set to locked. These are the cells that should not be changed without approval. The remainder of the cells that can be changed are set to unlocked and can be changed at will until it is time to lock them. I don't want changes tracked to the unlocked cells. There are multiple spreadsheets all of which are identical.

The following code does not do anything. It should track the changes to whatever target cell is picked. Then it should copy the old and new values of the target cell to sheet 3. I get nothing. There are also no errors showing up at all. As changes are made, the next change should show on the next free line. Please understand I am by no means fluent in VBA. This is all copy, paste, and massage. I'm trying to at least give it a try before I post. I don't want you to do it all for me. I want to learn. Where did I go wrong?
Thanks,
Jim

VBA Code: 
 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewValue, OldValue
    Dim wsCopy As Worksheet
    Dim wsDest As Worksheet
    Dim CopyTargetValue
    Dim DestTargetValue
   If Target.Locked = False Then
   End If
 If Target.Locked = True Then
    Application.EnableEvents = False
    With Target
        NewValue = .Value
        Application.Undo
        OldValue = .Value
        .Value = NewValue
       End With
    Set wsDest = ThisWorkbook.Worksheets("Sheet3")
       CopyTargetValue = wsCopy.Target.NewValue
       DestTargetValue = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
       wsDest.Range("B" & DestTargetValue).Value = wsCopy.Target.OldValue
       wsDest.Range("C" & DestTargetValue).Value = wsCopy.Target.NewValue
     Application.EnableEvents = True
 End If
End Sub
 
Sort by date Sort by votes

As no issue on my side so your worksheet is not smart …​
​
Link your workbook on a files host website like Dropbox for example …​
 
Upvote 0

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
I wish I could. However with the security here at work, Those sites are blocked. Also you need explicit authority to send an attachment by e-mail.
 
Upvote 0
Marc,
Looks like it was a computer glitch. I shut down re-booted and all SEEMS fine. Thank you again for the help!
 
Upvote 0
Okay,
I made a copy of the file I am adding the code to before I release it with the new code. Now I get a run time error. I have shown the error in the attached pictures. In the final sheet code there are several lock/unlock events that happen. It seems that when the new code runs, it "remembers" that a cell was locked, and tries to run the new code even if it shouldn't.

Here is the full code that is on each sheet. The code you helped me with is near the bottom. The part of the code that seems to be giving me trouble is Case 10.
VBA Code: 
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
    Dim V(1)
    If Target.CountLarge > 1 Then Exit Sub
      If Target.Locked = True Then
          With Application
           .EnableEvents = False
           V(1) = Target.Value
           .Undo
           V(0) = Target.Value
           Target.Value = V(1)
            With ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows
            Sheets("Sheet2").Unprotect "Password"
             .Item(.Count + 1).Columns("B:C").Value = V
             .Item(.Count + 1).Columns("D").Value = Environ("username")
             .Item(.Count + 1).Columns("E").Value = Now
             .Item(.Count + 1).Columns("F").Value = Target.Row
            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 = "John.Doe@acompany.com"
                myMail.Subject = "Changes made"
                myMail.HTMLBody = "Changes to file " & Application.ActiveWorkbook.Name
                myMail.send
             .EnableEvents = True
          End With
      End If
       Sheets("Sheet2").Protect "Password"
 Application.EnableEvents = True
   
End Sub

I hope you can see something I don't.
Jim
 

Attachments

  • undo.png
    undo.png
    6.6 KB · Views: 8
  • undo 2.png
    undo 2.png
    16.2 KB · Views: 8
Last edited by a moderator:
Upvote 0
One other thing. If I go back to rows of code that are already locked, the whole thing runs fine. It is only when new entries are made that I get the error.
Thanks,
Jim
 
Upvote 0
Okay I'll give it another try.

I removed the green check from the solution column in post #8 since the code is not working.

Maybe I am not getting a response from anyone because I am not explaining my problem well enough.

I am trying to track changes to cells in a worksheet that are locked and should not be changed. The only unlocked cells on the worksheet are those being actively worked on. Any data in unlocked cells should be able to be changed as needed. Columns H and L will only unlock if a particular entry is made in another cell. Once a user is done entering data, they enter yes in column M. This locks the row being worked on and unlocks the required cells in the next row for data entry.

The code in post #10 worked in a new blank workbook. I manipulated it to make it work with the rest of the code on each worksheet. The code works perfectly on any cell that is already locked. It is during new data entry that I get the error in post #14. I altered the code slightly. I changed it to try and make sure it only worked if all the cells in the target row were locked. That still didn't work. I still get the error in post #14.

Here is the latest complete code.

This is the latest code in the sheets.
VBA Code: 
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
    Dim V(1)
    If Target.CountLarge > 1 Then
    End If
      If Target.EntireRow.Locked = False Then
      End If
      If Target.EntireRow.Locked = True Then
          With Application
           .EnableEvents = False
           V(1) = Target.Value
           .Undo
           V(0) = Target.Value
           Target.Value = V(1)
            With ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows
            Sheets("Sheet2").Unprotect "exceler8"
             .Item(.Count + 1).Columns("B:C").Value = V
             .Item(.Count + 1).Columns("D").Value = Environ("username")
             .Item(.Count + 1).Columns("E").Value = Now
             .Item(.Count + 1).Columns("F").Value = Target.Row
            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 = "John.Doe@acompany.com"
                myMail.Subject = "Changes made"
                myMail.HTMLBody = "Changes to file " & Application.ActiveWorkbook.Name
                myMail.send
             .EnableEvents = True
          End With
      End If
       Sheets("Sheet2").Protect "password"
 Application.EnableEvents = True
    
End Sub

The error is probably simple or foolish. I just can not find it or make it work.
thanks again,
Jim
 
Upvote 0
I finally found a solution on my own. To get rid of the run time error I had to add in a range. When entering a value into column M this locks the column. This is where the run time error is generated.
As far as changes go, this column has little value after the fact. So I removed it from the change list. As far as a solution to my original problem in this thread, It is in post #8. as far as a complete solution to my problem it is this post #17. But I will give full credit to Marc L.

Here is my final code.
VBA Code: 
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
    Dim V(1)
    If Target.CountLarge > 1 Then
    End If
    If Not Intersect(Target, Range("B6:L5000, N6:N5000")) Is Nothing Then
      If Target.Locked = True Then
          With Application
           .EnableEvents = False
           V(1) = Target.Value
           .Undo
           V(0) = Target.Value
           Target.Value = V(1)
            With ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows
            Sheets("Sheet2").Unprotect "password"
             .Item(.Count + 1).Columns("B:C").Value = V
             .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
            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 = "John.Doe@acompany.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
Thank you for the help,
Jim
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Combining 3 Worksheet_Change events
Replies
4
Views
305
Kevo
K
S
  • Question
Unable to remove drop down selection values from a cell
Replies
6
Views
493
S0ph1e
S
T
  • Solved
VBA - Seek user confirmation when changing non blank cells
Replies
6
Views
305
kevin9999
K
S
  • Question
Add Deselect VBA Coding for Multiselect Dropdown
Replies
1
Views
1K
John_w
J
S
  • Question
Worksheet Change Event
Replies
2
Views
387
sspatriots
S

Forum statistics

Threads
1,215,219
Messages
6,123,678
Members
449,116
Latest member
HypnoFant

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top