Help with Private Sub macro involving protected sheet and Data Validation

[uhguy]

Hi

The macro below works only if the sheet is not protected. How can we make it work when the sheet is locked? For all my module Macros i use a "unlock sheet" command but I have no idea how to do that with this macro since its a private sub and im not sure how or when to trigger the "call unlocksheet" macro I made.


Thanks!

Note on what this macro does: I have two sheets. Sheet one has a header on row 6 and the user is required to select from a drop down list in column C. The list is contained in sheet2 which i named the range as "DataList". I want to prevent a user from copying in data into column C on sheet one since it would get rid of the data validation i have in place. to prevent this, the macro below would undo last command if the range that should contain validations no longer has a validation in any cell. Also note that the range in sheet one is named "ValidationRange" and before this macro is written, every cell in that named range should already have a validation in place. If you have a better method than this id love to hear it. Thanks again!

Private Sub Worksheet_Change(ByVal Target As Range)



   If HasValidation(Range("validationrange")) Then
    
    

Exit Sub
      
Else

        Application.Undo
      MsgBox "Your last operation was canceled. " & _
      "It would have deleted data validation rules.", vbCritical
  '    Call ProtectIN
   End If
End Sub

Private Function HasValidation(r) As Boolean



   On Error Resume Next
  x = r.Validation.Type
 If Err.Number = 0 Then HasValidation = True Else HasValidation = False
End Function

 

[uhguy]

Chris,

The code works but only when the sheet is not protected. If I protect the sheet, it does not trigger the first test.
As you see below i made changes in Blue font. I put the code to unlock sheet but the macro never gets to it.
I have a feeling that the issue is with the "Private Function HasValidation(r As Range) As Boolean". It may not get triggered.
Any way that we can do away with that private function and have the code be placed within the Private Sub, right after all the "Dim'S".
I cant thank you enough for helping me. This is by far the hardest code I've needed and its driving me insane.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPassword As String
Dim rCell As Range
Dim vTemp As Variant
[COLOR=#0000ff]myPassword = "pw"[/COLOR]

'MAYBE WE PUT THE BOOLEAN TEST HERE AND DELETE THE PRIVATE FUNCTION BELOW???

'only work in target range
If Intersect(Target, Sheet1.Range("A2:A7")) Is Nothing Then
    Exit Sub
End If

'validation rule check
For Each rCell In Target
    If HasValidation(Target) = False Then 'validation is broken, need to undo
        Application.EnableEvents = False
        
       [COLOR=#ff0000] 'I pasted the sheet unlock code here but it doesnt unlock the sheet, so the undo function does not kick in.[/COLOR]
       [COLOR=#0000ff] Worksheets("Sheet1").Unprotect Password:=myPassword[/COLOR]
        
        Application.Undo
        Application.EnableEvents = True
        MsgBox "Do not paste in to these cells. Changes have been undone"
        Exit Sub
    End If
Next rCell

'Now check for pasted illegal values
For Each rCell In Target
    vTemp = Application.Match(rCell.Value, Sheet2.Range("A2:A4"), 0)
    Application.EnableEvents = False
    'the following code block will not make sense if the user pastes 2 cells at once. One
    'cell might pass, the next might fail. Only the values of the second cell will be shown.
    If IsError(vTemp) Then
        Sheet1.Range("B1").Value = "FALSE - ERRORS EXIST"
        'I would like an "application.undo" here but its not possible....
        
        [COLOR=#0000ff]Application.ActiveCell.ClearContents[/COLOR] ' [COLOR=#ff0000]this as you mention works only one the first item pasted.. but if user copies and paste more than one it only clears the first cell. Im trying to see a way around this that checks which cells do not match the list in sheet 2 and ClearsContents on all.
        
        [/COLOR]
    Else
        Sheet1.Range("A1").Value = "TRUE- ERROR FREE"
[COLOR=#0000ff]        Sheet1.Range("B1").Clear[/COLOR]
    End If
    Application.EnableEvents = True
Next rCell

Set rCell = Nothing
   
End Sub

Private Function HasValidation(r As Range) As Boolean

On Error Resume Next

x = r.Validation.Type
 If Err.Number = 0 Then
    HasValidation = True
Else
    HasValidation = False
End If

End Function

 

[ChrisM]

Here is the revision to fix your request of clearing each individual cell that does not match. The application.undo code is not firing because the data validation rules are still there when you paste values in. I was not able to figure out how you are killing the rules after pasting. I pasted some text values, then pasted a cell with a totally different validation rule, but it had no effect, the correct validation was there the whole time. To prove it to yourself, manually remove the validation from cell A7. Now paste an incorrect value in to A7 and watch what happens.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPassword As String
Dim rCell As Range
Dim vTemp As Variant
myPassword = "pw"

'only work in target range
If Intersect(Target, Sheet1.Range("A2:A7")) Is Nothing Then
    Exit Sub
End If

'validation rule check
For Each rCell In Target
    If HasValidation(Target) = False Then 'validation is broken, need to undo
        Application.EnableEvents = False
        
        'I pasted the sheet unlock code here but it doesnt unlock the sheet, so the undo function does not kick in.
        Worksheets("Sheet1").Unprotect Password:=myPassword
        
        Application.Undo
        Application.EnableEvents = True
        MsgBox "Do not paste in to these cells. Changes have been undone"
        Exit Sub
    End If
Next rCell

'Now check for pasted illegal values
For Each rCell In Target
    vTemp = Application.Match(rCell.Value, Sheet2.Range("A2:A4"), 0)
    Application.EnableEvents = False
    'the following code block will not make sense if the user pastes 2 cells at once. One
    'cell might pass, the next might fail. Only the values of the second cell will be shown.
    Sheet1.Unprotect myPassword
    If IsError(vTemp) Then
        Sheet1.Range("B1").Value = "FALSE - ERRORS EXIST"
        rCell.Value = ""
    Else
        Sheet1.Range("A1").Value = "TRUE- ERROR FREE"
        Sheet1.Range("B1").Clear
    End If
    Sheet1.Protect myPassword
    Application.EnableEvents = True
Next rCell

Set rCell = Nothing
   
End Sub

Private Function HasValidation(r As Range) As Boolean

On Error Resume Next

x = r.Validation.Type
 If Err.Number = 0 Then
    HasValidation = True
Else
    HasValidation = False
End If

End Function

 

[uhguy]

YEEEEEEEEESSSSSSSSSSSSSSSS!!!!!!!!!!!!!!!!!!!!


It works!!! THANK YOU!

I was ready to give up on this. Wow, thank you very much. I dont know what was different on this last code or what was going on but prior to that, if the sheet was locked, i was successfuly able to past anything in the validationrange (A2-A7) and the undo would not fire. ill have to study this code vs what i had been trying but this really works. There are several post online about people trying to do this and none had a happy ending.

 

[uhguy]

The code below is what I'm using now. As you see i tried to modify it where the red font is. As the code is now, if we hit the delete button to clear the data in sheet 1, range A2-A7, we get the pop up message we intended to get only of people pasted invalid data.

my attempt below was checking if cell is blank, then skip the pop up.
If nothing else, ill just modify what the popup says to "Cell has been cleared. Select or paste-in valid data"

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPassword As String
Dim rCell As Range
Dim vTemp As Variant
myPassword = "pw"

'only work in target range
If Intersect(Target, Sheet1.Range("A2:A7")) Is Nothing Then
    Exit Sub
End If

'validation rule check
For Each rCell In Target
    If HasValidation(Target) = False Then 'validation is broken, need to undo
        Application.EnableEvents = False
        
        Worksheets("Sheet1").Unprotect Password:=myPassword
        
        Application.Undo
        Application.EnableEvents = True
        MsgBox "Do not paste in to these cells. Changes have been undone1"
        Exit Sub
    End If
Next rCell

'Now check for pasted illegal values


On Error Resume Next

        For Each rCell In Target
            vTemp = Application.Match(rCell.Value, Sheet2.Range("A2:A4"), 0)
            Application.EnableEvents = False
            
            Sheet1.Unprotect myPassword
            
            If IsError(vTemp) Then
                
                rCell.Value = " "
                        [COLOR=#ff0000]'If Target.Cells.Value = "" Then
                                 'do nothing[/COLOR]
                       [COLOR=#ff0000] 'Else[/COLOR]
                            'pop up message
                            MsgBox "Do not paste in to these cells. Cell has been cleared. Select from drop down"
                            'End If
            Else
              
                Sheet1.Range("B1").Clear
         
            End If
            Sheet1.Protect myPassword
            Application.EnableEvents = True
        Next rCell
        Set rCell = Nothing
   
End Sub

Private Function HasValidation(r As Range) As Boolean

On Error Resume Next

x = r.Validation.Type
 If Err.Number = 0 Then
    HasValidation = True
Else
    HasValidation = False
End If

End Function