PDA

View Full Version : How to Merge Two Worksheet_Change Codes



mervesy
07-08-2019, 05:18 AM
Hi,
I am trying to merge two VBA codes;

Code1:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 4 Then
Target.Offset(0, 1).ClearContents
Target.Offset(0, 2).ClearContents
Target.Offset(0, 3).ClearContents
Target.Offset(0, 4).ClearContents
Target.Offset(0, 5).ClearContents
Target.Offset(0, 6).ClearContents
Target.Offset(0, 7).ClearContents
Target.Offset(0, 8).ClearContents
Target.Offset(0, 9).ClearContents
Target.Offset(0, 10).ClearContents
Target.Offset(0, 11).ClearContents
End If
End Sub



Code2:

Private Sub Worksheet_Change(ByVal Target As Range)
Set xxx = Intersect(Target, Range("E2:O10000"))
If Not xxx Is Nothing Then
If HasValidation(xxx) Then
Exit Sub
Else
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Your last operation was cancelled. It would have deleted data validation rules.", vbCritical
End If
End If
End Sub


Private Function HasValidation(r) As Boolean
HasValidation = True
'Returns True if every cell in Range r uses Data Validation
On Error Resume Next
For Each cll In r.Cells
x = cll.Validation.Type
If Err.Number <> 0 Then
HasValidation = False
Exit For
End If
Next cll
End Function


It looks like i have to change something but i couldn't find. Is there anyone to explain?

Thanks!

Artik
07-08-2019, 10:06 PM
Probably:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range

Application.EnableEvents = False

If Target.Column = 4 Then
If Target.Row > 1 Then
Target.Offset(, 1).Resize(, 11).ClearContents
End If
End If

Set Rng = Intersect(Target, Range("E2:O10000"))

If Not Rng Is Nothing Then
If HasValidation(Rng) Then
GoTo EndProc
Else
Application.Undo
MsgBox "Your last operation was cancelled. It would have deleted data validation rules.", vbExclamation
End If
End If

EndProc:
Application.EnableEvents = True
End Sub

Artik

mervesy
07-09-2019, 12:17 AM
Probably:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range

Application.EnableEvents = False

If Target.Column = 4 Then
If Target.Row > 1 Then
Target.Offset(, 1).Resize(, 11).ClearContents
End If
End If

Set Rng = Intersect(Target, Range("E2:O10000"))

If Not Rng Is Nothing Then
If HasValidation(Rng) Then
GoTo EndProc
Else
Application.Undo
MsgBox "Your last operation was cancelled. It would have deleted data validation rules.", vbExclamation
End If
End If

EndProc:
Application.EnableEvents = True
End Sub

Artik

Hi,
Thanks for your reply. I have tried this code but it shows error alert on If HasValidation(Rng) Then and shows this message: compile error:sub or function not defined.

How can we fix this problem?

Thanks

Artik
07-09-2019, 02:05 AM
The message clearly says that the function is missing. Then add the entire HasValidation code to the module.

Artik

mervesy
07-09-2019, 02:34 AM
Many thanks for your help. Could you please explain me how to add HasValidation code to the module? I am not an expert on VBA.

Artik
07-09-2019, 04:07 AM
You have pasted the code to the module that I showed earlier. Paste the following code under it:

Private Function HasValidation(r) As Boolean

HasValidation = True

'Returns True if every cell in Range r uses Data Validation
On Error Resume Next
For Each cll In r.Cells
x = cll.Validation.Type
If Err.Number <> 0 Then
HasValidation = False
Exit For
End If
Next cll
End Function

Artik

mervesy
07-09-2019, 06:06 AM
Thanks for your help. It works fine for a couple of time but then it shows below error for Application.Undo line

Run time error 1004: Method Undo of object _Application failed.