VBA to Prevent Data Entry in Cell with Data Validation List - Two Criteria Validation

I got some great help with this bit of code a while back:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("D16:G180")) Is Nothing Then Exit Sub
    Dim cell As Range
    For Each cell In Range(Cells(16, Target.Column), Cells(180, Target.Column)) 'Match the range extremes
        If Len(cell.Value) <> 0 Then
            Dim MaxCount As Long
            MaxCount = Range("X6:X25").Cells(Application.Match(cell.Value, Range("W6:W25"), 0))
            If Application.WorksheetFunction.CountIf(Range(Cells(16, Target.Column), Cells(180, Target.Column)), cell.Value) > MaxCount Then  'Match the range extremes
                MsgBox "This subject is already full in this option block. Please choose something else."
                With Application
                    .EnableEvents = False
                    .Undo
                    .EnableEvents = True
                End With
                Exit For
            End If
        End If
    Next cell
End Sub

The range used for the lookup (W6:X25) has now needed to change to this:

Excel 2016 (Windows) 32 bit

	W	X	Y
5	Option	Subject	Capacity
6	A	Ar	72
7	B	Ar	48
8	C	CP	24
9	D	CP	24
10	D	ClasCi	24
11	A	DT	48
12	B	DT	72
13	A	Dr	24
14	B	Dr	24
15	C	Fr	48
16	D	Fr	24
17	D	FrAI	24
18	C	Gm	24
19	D	La	48
20	A	Mu	24
21	B	Mu	24
22	C	Sp	72
23	D	Sp	24
24	D	SpAI	76

Sheet: Y9 Options

The options refer to:

A D16:D180

B E16:E180

C F16:F180

D G16:G180

How can I change the code to work on each of these ranges separately? Would the lookup table be better in a different format (this can change if necessary)?

Thanks for any help!

Hi Ali

Would be great if you are able to upload your sample file with all the required information...Especially the values in these ranges...
A D16:D180
B E16:E180
C F16:F180
D G16:G180

I can't upload a workbook at the moment unfortunately, however D16 to G180 looks like this:

Excel 2016 (Windows) 32 bit

	D	E	F	G
15	A	B	C	D
16	Dr	DT	CP	Sp
17	Dr	DT	Sp	ClasCi
18	Ar	DT	Fr	SpAI
19	Ar	DT	Fr	ClasCi
20	DT	Mu	Sp	CP
21	Ar	DT	Fr	SpAI
22	Dr	Ar	Sp	La
23	DT	Mu	Gm	CP
24	DT	Mu	Sp	CP
25	Dr	Ar	Gm	La
26	Ar	Dr	Sp	La
27	DT	Dr	Fr	SpAI
28	Ar	DT	Sp	ClasCi
29	Dr	DT	Sp	ClasCi
30	Mu	DT	Sp	ClasCi
31	DT	Ar	Sp	La
32	DT	Ar	CP	Fr

Sheet: Y9 Options

Here's the thread where I was given the code above: https://www.excelforum.com/excel-pro...tion-list.html

Sample workbook now attached with the code I had from the previous thread working. What I want to change is the way that the code looks up the capacity value: the values for each option column can be different. Please ask if anyone needs further clarification. Thank you!

Perhaps...Don't see the need for a loop

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, MaxCount, aFormula
Set rng = Range(Cells(2, Target.Column), Cells(11, Target.Column))
If Intersect(Target, rng) Is Nothing Then Exit Sub
If Len(Target.Value) <> 0 Then
    aFormula = "=INDEX(M2:M15,MATCH(" & Cells(1, Target.Column).Address & " & " & Target.Address & ",K2:K15&L2:L15),0)"
    MaxCount = Evaluate(aFormula)
    If Application.WorksheetFunction.CountIf(rng, Target.Value) > MaxCount Then
        MsgBox "This subject is already full in this option block. Please choose something else."
        With Application
            .EnableEvents = False
            .Undo
            .EnableEvents = True
        End With
    End If
End If
End Sub

Thanks - I will give it a go and let you know.

EDIT: It works perfectly on my sample file - thank you. I will now try to adapt it for the real thing.

OK - so it's not working as I had hoped (sorry - I cannot share the actual workbook, so bear with me).

I have adapted the code to fit my new layout thus:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, MaxCount, aFormula
Set rng = Range(Cells(16, Target.Column), Cells(150, Target.Column))
If Intersect(Target, rng) Is Nothing Then Exit Sub
If Len(Target.Value) <> 0 Then
    aFormula = "=INDEX(Y6:Y30,MATCH(" & Cells(15, Target.Column).Address & " & " & Target.Address & ",W6:W30&X6:X30),0)"
    MaxCount = Evaluate(aFormula)
    If Application.WorksheetFunction.CountIf(rng, Target.Value) > MaxCount Then
        MsgBox "This subject is already full in this option block. Please choose something else."
        With Application
            .EnableEvents = False
            .Undo
            .EnableEvents = True
        End With
    End If
End If
End Sub

Lookup table:

Excel 2016 (Windows) 32 bit

	W	X	Y
5	Option	Subject	Capacity
6	A	Ar	28
7	B	Ar	48
8	C	CP	24
9	D	CP	24
10	D	ClasCi	24
11	A	DT	48
12	B	DT	72
13	A	Dr	24
14	B	Dr	24
15	C	Fr	48
16	D	Fr	24
17	D	FrAI	24
18	C	Gm	24
19	D	La	48
20	A	Mu	24
21	B	Mu	24
22	C	Sp	72
23	D	Sp	24
24	D	SpAI	76

Sheet: Y9 Options

Working area (there are entries down as far as row 91):

Excel 2016 (Windows) 32 bit

	D	E	F	G
15	A	B	C	D
16	Dr	DT	CP	Sp
17	Dr	DT	Sp	ClasCi
18	Ar	DT	Fr	SpAI
19	Ar	DT	Fr	ClasCi
20	DT	Mu	Sp	CP
21	Ar	DT	Fr	SpAI
22	Dr	Ar	Sp	La
23	DT	Mu	Gm	CP
24	DT	Mu	Sp	CP
25	Dr	Ar	Gm	La
26	Ar	Dr	Sp	La
27	DT	Dr	Fr	SpAI
28	Ar	DT	Sp	ClasCi
29	Dr	DT	Sp	ClasCi
30	Mu	DT	Sp	ClasCi
31	DT	Ar	Sp	La
32	DT	Ar	CP	Fr

Sheet: Y9 Options

There are currently 30 who have opted for DT in option B, and the capacity for that option is 72, however if I try to change an option in that column to DT, I get the option full message. What have I done wrong, please?

Can't see anything wrong offhand...Tried to mock-up a file with the info you have given but no avail...

Perhaps:

aFormula = "=LOOKUP(2,1/(W6:W30=" & Cells(15, Target.Column).Address & ")/(X6:X30=" & Target.Address & "),Y6:Y30)"

Of Course...my bad...omitted the Column Ref

EDIT...Also, forgot to declare

MaxCount as long

aFormula = "=INDEX(Y6:Y30,MATCH(" & Cells(15, Target.Column).Address & "&" & Target.Address & ",W6:W30&X6:X30,0),1)"

Thanks, chaps!

Rory - that seems to work - thanks!

Sintek - I wasn't sure where to put the declaration (sorry - not good with VBA).

I will test a bit more and see if the code works properly for other columns.

Its a Dimension statement that can go at the top of your Code.

Dim MaxCount as Long

it is currently in your code as a variant, however, so you may not need it.

Seems to be working really well - thank you.

Seems to be working really well - thank you

Are you referring to the corrected aformula = code Post #10

Sorry, I wasn’t clear - I went with Rory’s variation, but thank you for your help.

All good...Post 10 did however solve...

Yes - it's just that I couldn't get the declaration right, so I tried Rory's, which worked straight off. But thanks once again for your suggestion - I do appreciate it.

Glad it is sorted...

Sorry to reopen this, but I have found a slight glitch with the code I ended up using (below). I get a runtime error 13 type mismatch error if I try entering any data into the other columns of the table. How do I limit the range to columns D, E, F and G? In other words, I only want the code to execute if I am accessing cells in the range specified (rows 15 to 150) in columns D to G. Hope this is clear.

Thanks for any help.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, MaxCount, aFormula
' SINTEK: MaxCount As Long
Set rng = Range(Cells(16, Target.Column), Cells(150, Target.Column))
If Intersect(Target, rng) Is Nothing Then Exit Sub
If Len(Target.Value) <> 0 Then
    aFormula = "=LOOKUP(2,1/(W6:W30=" & Cells(15, Target.Column).Address & ")/(X6:X30=" & Target.Address & "),Y6:Y30)"
    ' SINTEK: aFormula = "=INDEX(Y6:Y30,MATCH(" & Cells(15, Target.Column).Address & " & " & Target.Address & ",W6:W30&X6:X30),1)"
    MaxCount = Evaluate(aFormula)
    If Application.WorksheetFunction.CountIf(rng, Target.Value) > MaxCount Then
        MsgBox "This subject is already full in this option block. Please choose something else."
        With Application
            .EnableEvents = False
            .Undo
            .EnableEvents = True
        End With
    End If
End If
End Sub

Hi AliGw

Quite tricky trying to remember what was actually being achieved...

Set rng = Range(Cells(16, 4), Cells(150, 7))

Perfect - thanks!

Pleasure...