Problems with .Undo and drop down lists.

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
125
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: 8
  • undo.png
    undo.png
    6.6 KB · Views: 9

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
125
Office Version
  1. 365
Platform
  1. Windows
So if I have to live with adding extra columns then so be it. I added the code you gave me like this.....
VBA Code:
Private Const rg As String = "G6:G5000, J6:J5000"
 Dim old
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
                 .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
                 :=xlBetween
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
           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
 
 End Sub
 
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
   If Target.Locked = True Then

        Application.EnableEvents = False
            Target.Offset(, 17) = old
        Application.EnableEvents = True

    End If
End Sub


           With ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows
            Sheets("Sheet2").Unprotect "passwor"
             .Item(.Count + 1).Columns("B").Value = Target.Value
             .Item(.Count + 1).Columns("C").Value = old
             .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
            End If
      End If
       Sheets("Sheet2").Protect "password"
      
     
 Application.EnableEvents = True
   
End Sub
Now I get the compile error in the attached picture.
Where do I go from here?

Jim
 

Attachments

  • compile error.png
    compile error.png
    36.8 KB · Views: 2

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
3,653
Office Version
  1. 365
Platform
  1. Windows
Sorry for the late reply.

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


If you to return the old value in the same column, column "S" all the time.
Cells(Target.Row, "S").Value = old

but I don't think tou need that.
If I understand you correctly, you want to return the old & new value to col B:C in this part
Sheets("Sheet2").Unprotect "password"
.Item(.Count + 1).Columns("B:C").Value = V


so try this:

Rich (BB code):
Dim old

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("B6:L5000, N6:N5000")) 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
           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 Exit Sub
    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("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
            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
 
Solution

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
125
Office Version
  1. 365
Platform
  1. Windows
Looks like we have a winner!!! sorry for the long pause in response. I wanted to see if I could make things go bad. So far so Good!

Everything SEEMS to work PERFECTLY! Here is the final code.

VBA Code:
Dim old
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("B6:L5000, N6:N5000")) 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:L5000, N6:N5000")) 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 = "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 so much for the help!
Jim
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,479
Messages
5,770,323
Members
425,612
Latest member
martinijr

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
Top