Multiple Worksheet_Change Functions

[AmeliaBedelia]

I found Worksheet_Change code that works like a charm for one row, but I want to be able to duplicate or run the code for multiples rows. What this code does is pops up a warning message stating "Only one entry allowed." and will not allow the user to enter in another entry until they clear out the previous entry in that same row. For example there are 5 rows of questions (F13:F17). In column G through I the user is able to select an 'x' from a data validation drop down list. I want this pop up to display if they try to select two 'x' in the same row. So for row 13 they select a response (x) in either G13, H13 or I13. The code below only allows them to select one 'x' in either G13, H13 or I13 and when they try to select a second option in these three cells it pops up the warning message.

I want to duplicate this code so that this happens in row 14-17. Each row is a separate question and needs to stand alone.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range


Set rLook = Range("G13:I13")
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
If Intersect(Target, rLook) Is Nothing Then Exit Sub
If wf.CountA(rLook) < 2 Then Exit Sub
Application.EnableEvents = False
Target.ClearContents
MsgBox "Only one entry allowed"
Application.EnableEvents = True


End Sub


Hopefully I explained it well enough.
Thanks

 

[Fluff]

Try

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim wf As WorksheetFunction
   
   Set wf = Application.WorksheetFunction
   If Intersect(Target, Range("G13:I17")) Is Nothing Then Exit Sub
   If wf.CountA(Range("G" & Target.Row).Resize(, 3)) < 2 Then Exit Sub
   Application.EnableEvents = False
   Target.ClearContents
   MsgBox "Only one entry allowed"
   Application.EnableEvents = True
End Sub

 

[JoeMo]

If there's a possibility that a user will attempt a paste to multiple rows that includes some or all of G13:I17, here's another version that clears offending rows one-at-a-time.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, Rw As Range
Set rLook = Range("G13:I17")
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
If Intersect(Target, rLook) Is Nothing Then Exit Sub
For Each Rw In rLook.Rows
    If wf.CountA(Rw) > 1 Then
        Application.EnableEvents = False
        Rw.ClearContents
        MsgBox "Only one entry allowed in range " & Rw.Address(0, 0)

    End If
Next Rw
Application.EnableEvents = True
End Sub

 

[AmeliaBedelia]

Thank you for such fast replies. I got it to work using the first code from Fluff.
JoeMo, I do not completely understand what you mean by a "possibility that the user will attempt a paste to multiple rows" - can you provide an example?
Just want to make if this relates to what I am building or not.
Thanks

 

[JoeMo]

Copy a pattern like the one below and paste it to G13.

Excel Workbook
	S	T	U
11	x	x	x
12	x
13	x		x
14	x
15	x	x	x
Sheet4

 

[AmeliaBedelia]

Okay, now I understand. My users would not have anything to copy from, so this should not be an issue. That being said I did copy a pattern like that into G13 and the message box still appeared stating they could not have more than one entry. Thanks so much to both of you - it works like a charm now!

 

[Fluff]

Glad we could help & thanks for the feedback