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

 

[ChrisM]

You can't prevent them from pasting values like that with Validation. Using VBA to detect and manage copy/paste operations is difficult (but not impossible). I think your best bet is to test each value in C against your list of allowed values. This is not hard, you just need to figure out which workbook/worksheet event will trigger the search. Since you are already using Worksheet_Change you might as well put the code in there.

The easiest way to do this is to add a new hidden column (D for example) to sheet1. Set a formula from D6:D10000:

=IF(C6="",0,IF(ISERROR(MATCH(C6,Sheet2!A1:A3,0)),1,0)) 'replace A1:A3 with the list of allowed Validation values

So this formula will give you a "1" every time an invalid item appears.

Now your VBA code just needs to scan down the hidden column and check for any "1"s:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rcell As Range

For Each rcell In Sheet2.Range("D6:D10000")
    If rcell.Value = 1 Then
        MsgBox "bad value at " & rcell.Address
    End If
Next rcell

Set rcell = Nothing

End Sub

 

[uhguy]

Chris thanks a lot that code works. I dont mind having a hidden row but is there a way that the formula get written on column D after any data is typed on column C, whether typed or copied?
I have something in mind but dont yet know how to write.

it would be something like this,

Private Sub Worksheet_Change(ByVal Target As Range)


if active cell on column C is changed, offset (0, 1).FormulaR1C1 = "=IF(RC[-1]="""",0,IF(ISERROR(MATCH(RC[-1],sheet2!R2C1:R15C1,0)),1,0))"
(This would basically offset one column to the right of where the change occurred and past the formula.)

THen add you code here.

i know its butchered but what do you think? possible?

Really appreciate your help.

 

[ChrisM]

Yes you can do that. The Target range tells you exactly where the user is at. But I don't understand what you are trying to do. I was recommending placing that formula in every row, but now you want to place it row by row as the user enters data?

 

[uhguy]

Awesome. Yes I would like the formulas to be placed in column d one at a time as the user enters data or pastes on column C. And the cursor return to the previous spot. Thanks!

 

[ChrisM]

Well for that matter just forget putting in the formula and test within your Change sub, you'll get the same result without the extra work.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPassword As String
dim rCell a Range
dim vTemp as Variant

myPassword = "pw"

If HasValidation(Range("validationrange_Country")) Then
       Range("A1").Select
       Worksheets("Sheet1").Unprotect Password:=myPassword
       Application.Undo
      MsgBox "Your last operation was canceled. " & _
      "It would have deleted data validation rules.", vbCritical
Else
     For Each rCell in Target
          vTemp = Application.MATCH(rCell.Value,Sheet2.Range("A1:A3"),0) 'replace A1:A3 with your list of validation values
          If IsError(vTemp) Then
                  MsgBox "bad value at " & rcell.Address 'you can replace this line with Undo, or maybe clear the bad value out?
          End If
     Next rCell
End If
   
End Sub

 

[uhguy]

Hi again Chris! I have been trying your last code for some time now but cant get it to work. I did fix the "dim rCell a Range" to "dim rCell as Range" and then pasted the function code below this code which i think you wanted me to do but still cant get it to run with out errors.

 

[ChrisM]

Please post the code you are using and the specific error message

 

[uhguy]

The code below is what im trying to use. To test it i have two sheets, "sheet1" and "sheet2".


SHEET2

	A	B
1	LIST of Allowable Data for Sheet1
2	USA
3	CANADA
4	MEXICO

<tbody>
</tbody>

Range A2-A4 is named "List" and used on sheet1 validation rule


SHEET1

	A	B
1	ENTER COUNTRY FROM DROP DOWN IN CELLS A2-A7
2		JAPAN
3
4
5
6
7

<tbody>
</tbody>

CELLS A2-A7 are named "ValidationRange"
This range allows input from a drop down list. This list is on Sheet2 and the range called "List"

To test is private sub works, i copy cell B2 which does not have a validation rule and try and paste in the range "validationRule" (A2-A7), if this causes an error, move cursor to B1 and type "FALSE - ERRORS EXIST", Else move cursor to A1 and type "TRUE- ERROR FREE"


The error says "Object required" and point to the line ---->"vTemp = Application.Match(rCell.Value, Sheet2.Range("A1:A3"), 0) 'replace A1:A3 with your list of validation values"

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPassword As String
Dim rCell As Range
Dim vTemp As Variant


If HasValidation(Range("ValidationRange")) Then
       Range("A1").Value = "TRUE- ERROR FREE"
Else
     For Each rCell In Target
          vTemp = Application.Match(rCell.Value, Sheet2.Range("A2:A4"), 0) 'replace A1:A3 with your list of validation values
          If IsError(vTemp) Then
        
        Range("B1").Value = "FALSE - ERRORS EXIST"
        End If
     Next rCell
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

THANKS CHRIS!

 

[ChrisM]

Here's how I would write your entire procedure, try this one:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPassword As String
Dim rCell As Range
Dim vTemp As Variant

'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
        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"
    Else
        Sheet1.Range("A1").Value = "TRUE- ERROR FREE"
    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

note my comments about the user pasting in more than one cell.

 

[uhguy]

Thanks Chris let me give it a try.