Problems with .Undo and drop down lists.

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
153
Office Version
  1. 365
Platform
  1. Windows
I hope all of you are staying safe and healthy. I also hope you can help with this problem.

This is a small section of allot of code that is giving me trouble. It is to track worksheet changes. I have this code in each sheet of my workbook.

VBA Code:
  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"

It works "almost" perfectly. I say almost, because drop down lists give me 1004 run time errors. It happens as soon as you change the list, every time. With any other change, to any other cell, the code works fine.
Attached are pictures of the errors.
What is so different about a drop down list that causes the error? How do I fix it?

Thank you in advance,
Jim
 

Attachments

  • undo 2.png
    undo 2.png
    16.2 KB · Views: 11
  • undo.png
    undo.png
    6.6 KB · Views: 12

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
I see allot of people looking at this but no takers. Here is the rest of the code. Maybe with this someone will be able to help.
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

Again Thank you,
Jim
 
Upvote 0
I have tried a number of different "fixes" for this.
My last try was the following. It is only the part of the code that I cannot fix The entire code is in post #2
VBA Code:
Dim oldval As String
 Dim newval As String
 Dim rngDV As range
  Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
    If Target.CountLarge > 1 Then
    End If
    If Not Intersect(Target(1, 1), rngDV) Is Nothing Then
         If Target.Locked = True Then
          With Application
           .EnableEvents = False
           newval = Target.Value
           .Undo
           oldval = Target.Value
           Target.Value = newval
               With ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows
                Sheets("Sheet2").Unprotect "password"
                .Item(.Count + 1).Columns("B").Value = oldval
                .Item(.Count + 1).Columns("C").Value = newval
                .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"

This STILL gives me the 1004 error if the cell has a drop down list.

I at least hope this will get me closer to an answer.

Best,
Jim
 
Upvote 0
Okay this is the last thing I could figure out to try. I added the following two line of code to my project to remove the drop down lists after the final selection confirmation.
VBA Code:
Cells(z.Row, "G").Validation.Delete
Cells(z.Row, "J").Validation.Delete
I figured that if my code did not like the drop down lists, then I will remove them after the entry is made. YET, I am still plagued with the 1004 error even after they are removed. My code still works on ANY cell that DID NOT have a drop down list to begin with. It is only those cells that have, or had a drop down list that are giving me problems.
Here is my entire 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
           Cells(z.Row, "G").Validation.Delete
           Cells(z.Row, "J").Validation.Delete
            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
I hope someone can help.
Jim
 
Upvote 0
Hi, @XrayLemi
For debugging purpose, what happen if you unlock the target range? Does the Undo work?
 
Upvote 0
Hi Akuini,
When changes are made to the locked cells the sheet is unprotected first. I had not tried to set the cell attributes to unlocked. But that sort of defeats the purpose. It is only locked cells that I need to track changes to. I will try to set the cells to unlocked and see if that changes anything.
 
Upvote 0
Just tried two things. Changed cell attributes to unlocked and code ignored the cell since it was unlocked. Then changed the cell back to locked and got the same run time error.
 
Upvote 0
Another solution:
You use Undo to get the before value after you change the target range value.
Here's another way without using Undo.
This is an Event Procedure, you need to put it in the code module of the sheet in question.

Try it on a fresh sheet. You can try inserting a value in A1 then change it, the before value will be sent to col B.

VBA Code:
Dim old
Private Const rg As String = "A1:A5"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range(rg)) Is Nothing Then
        old = Target.Value
    End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range(rg)) Is Nothing Then
        
        Application.EnableEvents = False
            Target.Offset(, 1) = old
        Application.EnableEvents = True
        
    End If

End Sub
 
Upvote 0
Hi Akuini,,
I am very new to allot of this but, think I see what you did. I will experiment with this and see what I get. It will take time so forgive me if it takes me a while to get back to you.
Jim
 
Upvote 0
Okay, please bear with me. I have a bunch of questions about the code you gave me. I had allot of help with the code I already have. There was also allot of cut, paste and edit.

When I use your code on a blank sheet, it returns the old value in the next column over. I even tried it with a drop down list and that worked fine as well. I understand that now I can use that column's value in this section of my code.
VBA Code:
.Item(.Count + 1).Columns("C").Value = Target.Row.Cells("S").Value

I need the code to return the old value in the same column, column "S" all the time. because if I use this....
VBA Code:
Target.Offset(, 1) = old
Then each time a value is changed in a different column the old value will show up in the column next to it. and over write that value. I tried this
VBA Code:
Target.Row.Cells("S").Value = old
but it didn't work.

I also made a copy of the workbook that I will be using. and I cannot figure where the code you gave me goes.
Sorry, I am a little overwhelmed.
Jim
 
Upvote 0

Forum statistics

Threads
1,212,938
Messages
6,110,782
Members
448,297
Latest member
carmadgar

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