VBA-Macro Prevent Copy Paste in Data Validation Cell

[Morshed_Dhaka]

Hello Everyone, I am facing a critical problem which I believe require macro to solve this problem. I tried to create the macro so many times but it is not working and not solving my problems. Really appreciate is some body helps me to solve this problem

In a worksheet I implied data validation rules within the cells "E7:E12". Data validation list data is already available in the file . When I select the data from drop down, it works perfectly. Also, If I want to type any data which is not available in the drop down menu it stops me and showing me error message. It also works fine.

But when I copy-paste-value paste data in those data validation cells from any other location, it captured the data and doesn't imply the data validation rules.

I am looking for a macro that will restrict user to copy/paste/value paste any data from anywhere except the data which is already available in data validation list. The macro should be applicable for only selected range. In this case the range should be "E7: E12". In addition, if it can be done that if someone copy paste data from other location which has mixture of available & non available data & when user copy paste it, only available data will be taken and non available data will be automatically deleted with warning message box.

I am looking for expert help in this regard. I will ever grateful if someone able to give me the solution. Thanks.

 

[Joe4]

See here: https://www.extendoffice.com/documents/excel/2686-excel-drop-down-list-prevent-paste.html

 

[Morshed_Dhaka]

hi Joe, I already saw that code but it is not working in my situation. kindly read my requirements, then you will understand the difference

 

[Joe4]

What part isn't working?

It seems like it should be able to do what you want, except, maybe for this part:

In addition, if it can be done that if someone copy paste data from other location which has mixture of available & non available data & when user copy paste it, only available data will be taken and non available data will be automatically deleted with warning message box.

Is that the part that is tripping you up?

That part seems like it could be very tricky. The problem is, once you have Copied and Pasted, it is too late, the Validation list is already gone. So you really have nothing to check it against.
You need to approach it differently, maybe either by preventing them from using Copy & Paste altogether and create your own VBA code for Copy/Paste, or use VBA in a Worksheet_Change to also do the validation. That might work if you Validation list is static and not changing. Otherwise, you would need to edit the VBA code each time, or store the values in a list elsewhere on your sheet.

 

[Morshed_Dhaka]

Hi Joe Brother, thanks for your reply. My data validation list is static and it is not changing. Although, I am trying different approach for the solution of my problem but its not working. will be really really helpful if you kindly help to provide me the code based on my criteria

Thanks.& regards

 

[Joe4]

OK, I have created Worksheet_Change event procedure code that should do what you want. I even added code so that if they Copy and Paste values in, it will put the original Data Validation drop-down back in.
The only thing you should need to change is the array value in the dd variable (these are your drop-down values).
This code needs to be placed in proper sheet module. If you are unsure where to place it, just go to the sheet you want to apply it to, right-click on the sheet tab name at the bottom of the screen, select View Code, and paste the code in the resulting VBA editor window. Everything else should be automatic.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim isect As Range
    Dim cell As Range
    Dim dd As Variant
    Dim i As Long
    Dim mtch As Boolean
    Dim msg As String
    Dim myEntries As String
    
'   See if any updated cells fall in E7:E12
    Set isect = Intersect(Range("E7:E12"), Target)
    
'   Exit if updated cells do not fall in E7:E12
    If isect Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    
'   Set drop-down values
    dd = Array("apple", "banana", "cherry")
    
'   Loop through all intersecting cells
    For Each cell In isect
'       See if cell entry matches any drop-down values
        mtch = False
        For i = LBound(dd) To UBound(dd)
            If cell.Value = dd(i) Then
                mtch = True
                Exit For
            End If
        Next i
'       If value is not in list, erase and return message
        If mtch = False Then
            cell.ClearContents
            msg = msg & cell.Address(0, 0) & ","
        End If
    Next cell
    
'   Build string of validation entries
    For i = LBound(dd) To UBound(dd)
        myEntries = myEntries & dd(i) & ","
    Next i
    myEntries = Left(myEntries, Len(myEntries) - 1)
    
'   Reset validation
    With Range("E7:E12").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=myEntries
'        .IgnoreBlank = True
'        .InCellDropdown = True
'        .InputTitle = ""
'        .ErrorTitle = ""
'        .InputMessage = ""
'        .ErrorMessage = ""
'        .ShowInput = True
'        .ShowError = True
    End With
    
'   Return message, if necessary
    If Len(msg) > 0 Then
        MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
    End If

    Application.EnableEvents = True

End Sub

 

[Morshed_Dhaka]

Hi Joe Bro, it is absolutely fantastic. Many Many thanks to you. it works like a charm. But the code needs little bit modification to run it through a worksheet. the code is working fine if I remove the red color part from the code. I just want to know 2 more things from you if it is possible.

1. as per your guidance, I have to change the data validation list in the code ( dark blue colored, bold, italic). Is it possible that those data will be picked from a sheet cell reference cell ?? I mean if I change the data in that cell, then code will be run based on that cell data

2. I have a column with mobile number data. That column data must contains 11 digit mobile number data which is controlled by data validation rules. But I am facing same type of problem ( copy/paste) and data validation goes absolute. So, is this code will be applicable for that validation?? if not , then what I have to do ??


again, your code & support is absolutely fantastic. I wish I have VB knowledge like you. Many thanks again.



Private Sub Worksheet_Change(ByVal Target As Range)

Dim isect As Range
Dim cell As Range
Dim dd As Variant
Dim i As Long
Dim mtch As Boolean
Dim msg As String
Dim myEntries As String

' See if any updated cells fall in E7:E12
Set isect = Intersect(Range("E7:E12"), Target)

' Exit if updated cells do not fall in E7:E12
If isect Is Nothing Then Exit Sub

Application.EnableEvents = False

' Set drop-down values
dd = Array("apple", "banana", "cherry")

' Loop through all intersecting cells
For Each cell In isect
' See if cell entry matches any drop-down values
mtch = False
For i = LBound(dd) To UBound(dd)
If cell.Value = dd(i) Then
mtch = True
Exit For
End If
Next i
' If value is not in list, erase and return message
If mtch = False Then
cell.ClearContents
msg = msg & cell.Address(0, 0) & ","
End If
Next cell

' Build string of validation entries
For i = LBound(dd) To UBound(dd)
myEntries = myEntries & dd(i) & ","
Next i
myEntries = Left(myEntries, Len(myEntries) - 1)

' Reset validation
With Range("E7:E12").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=myEntries
' .IgnoreBlank = True
' .InCellDropdown = True
' .InputTitle = ""
' .ErrorTitle = ""
' .InputMessage = ""
' .ErrorMessage = ""
' .ShowInput = True
' .ShowError = True
End With

' Return message, if necessary
If Len(msg) > 0 Then
MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
End If

Private Sub Worksheet_Change(ByVal Target As Range)


Dim isect As Range
Dim cell As Range
Dim dd As Variant
Dim i As Long
Dim mtch As Boolean
Dim msg As String
Dim myEntries As String

' See if any updated cells fall in E7:E12
Set isect = Intersect(Range("E7:E12"), Target)

' Exit if updated cells do not fall in E7:E12
If isect Is Nothing Then Exit Sub

Application.EnableEvents = False

' Set drop-down values
dd = Array("apple", "banana", "cherry")

' Loop through all intersecting cells
For Each cell In isect
' See if cell entry matches any drop-down values
mtch = False
For i = LBound(dd) To UBound(dd)
If cell.Value = dd(i) Then
mtch = True
Exit For
End If
Next i
' If value is not in list, erase and return message
If mtch = False Then
cell.ClearContents
msg = msg & cell.Address(0, 0) & ","
End If
Next cell

Application.EnableEvents = True


' Build string of validation entries
For i = LBound(dd) To UBound(dd)
myEntries = myEntries & dd(i) & ","
Next i
myEntries = Left(myEntries, Len(myEntries) - 1)

' Reset validation
With Range("E7:E12").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=myEntries
' .IgnoreBlank = True
' .InCellDropdown = True
' .InputTitle = ""
' .ErrorTitle = ""
' .InputMessage = ""
' .ErrorMessage = ""
' .ShowInput = True
' .ShowError = True
End With

' Return message, if necessary
If Len(msg) > 0 Then
MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
End If


Application.EnableEvents = True

End Sub<strike></strike>

 

[Joe4]

the code is working fine if I remove the red color part from the code.

Somehow, the code got duplicated when I pasted it (so the part in red is just a copy of the code above it). There should only be one copy of it. I have gone back and corrected that.

1. as per your guidance, I have to change the data validation list in the code ( dark blue colored, bold, italic). Is it possible that those data will be picked from a sheet cell reference cell ?? I mean if I change the data in that cell, then code will be run based on that cell data

Yes. Can you provide the details?
Is it on the same sheet the data validation occurs on?
What cells are these values in?

2. I have a column with mobile number data. That column data must contains 11 digit mobile number data which is controlled by data validation rules. But I am facing same type of problem ( copy/paste) and data validation goes absolute. So, is this code will be applicable for that validation?? if not , then what I have to do ??

What is the exact data validation rule?
What range does this apply to?

 

[Morshed_Dhaka]

1. as per your guidance, I have to change the data validation list in the code ( dark blue colored, bold, italic). Is it possible that those data will be picked from a sheet cell reference cell ?? I mean if I change the data in that cell, then code will be run based on that cell data

Yes. Can you provide the details?
Is it on the same sheet the data validation occurs on?
What cells are these values in?

Sure, Why not. Example : Sheet1 contains A1=Apple, A2=Banana, A3= Cherry . List Data Validation implies into Sheet2 in the range E7:E12


2. I have a column with mobile number data. That column data must contains 11 digit mobile number data which is controlled by data validation rules. But I am facing same type of problem ( copy/paste) and data validation goes absolute. So, is this code will be applicable for that validation?? if not , then what I have to do ??

What is the exact data validation rule?
What range does this apply to?

Example : A1 to A100 range. Data validation rules implies that : Allow = "TEXT LENGTH" , Data = "EQUAL TO", Length = " 11"

 

[Joe4]

OK. Try this. I put all the ranges that may change at the very top as range variables. So those should be the only three things in the code that you may need to change.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng1 As Range
    Dim rng2 As Range
    Dim isect As Range
    Dim isect2 As Range
    Dim cell As Range
    Dim dd() As Variant
    Dim i As Long
    Dim mtch As Boolean
    Dim msg As String
    Dim myEntries As String
    Dim ddRange As Range
    
'***Set column E validation range
    Set rng1 = Range("E7:E12")
'***Set column A validation range
    Set rng2 = Range("A1:A100")
'***Set drop-down list value range
    Set ddRange = Sheets("Sheet1").Range("A1:A3")
    
    
'   See if any updated cells fall in column E range
    Set isect = Intersect(rng1, Target)
'   See if any updated cells fall in column A range
    Set isect2 = Intersect(rng2, Target)
    
'   Exit if updated cells do not fall in either validation range
    If (isect Is Nothing) And (isect2 Is Nothing) Then Exit Sub
    
    Application.EnableEvents = False


'   First check (column E)
    If Not isect Is Nothing Then
'       Build array of drop-down values
        ReDim dd(ddRange.Cells.Count)
        i = 0
        For Each cell In ddRange
            dd(i) = cell.Value
            i = i + 1
        Next cell
    
'       Loop through all intersecting cells
        For Each cell In isect
'           See if cell entry matches any drop-down values
            mtch = False
            For i = LBound(dd) To UBound(dd)
                If cell.Value = dd(i) Then
                    mtch = True
                    Exit For
                End If
            Next i
'           If value is not in list, erase and return message
            If mtch = False Then
                cell.ClearContents
                msg = msg & cell.Address(0, 0) & ","
            End If
        Next cell


'       Build string of validation entries
        For i = LBound(dd) To UBound(dd)
            myEntries = myEntries & dd(i) & ","
        Next i
        myEntries = Left(myEntries, Len(myEntries) - 1)
    
'       Reset validation
        With rng1.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=myEntries
        End With
    
'       Return message, if necessary
        If Len(msg) > 0 Then
            MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
        End If
    End If
    

'   Second check (column A)
    If Not isect2 Is Nothing Then
'       Loop through all intersecting cells
        For Each cell In isect2
            If (Len(cell) > 0) And (Len(cell) <> 11) Then
                cell.ClearContents
                msg = msg & cell.Address(0, 0) & ","
            End If
        Next cell
            
'       Reset validation
        With rng2.Validation
            .Delete
            .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
                Operator:=xlEqual, Formula1:="11"
        End With
    
'       Return message, if necessary
        If Len(msg) > 0 Then
            MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
        End If
    End If
    
    Application.EnableEvents = True

End Sub