VBA - Select any 2 out of 4 options (e.g. 6 combinations) within a greater range of options

Question

There is a list of ID's with their chosen subjects in their respective row. I am trying to write code that will read through the subjects, and ensure that any two out of a selected four of the subjects are chosen (out of 15 subjects), and if it isn't be reported back as an error. The subjects needed are either SBC130, SBC150, SBC210 or SBC220, and any combination of the 2 are good out of a range of 15 possible subjects.

This is the code I have so far


Dim programme, module, ID As String
Dim rng As Range
Dim a, b, c, d As Variant

lastidno = Range("A2", Range("A2").End(xlDown)).Count

For i = 2 To lastidno
Sheets("Part B + C Modules").Activate

Set rng = Range("C" & i, Range("C" & i).End(xlToRight))
For j = 1 To 4
    Set a = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC130", LookIn:=xlValues, lookat:=xlWhole)
    Set b = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC150", LookIn:=xlValues, lookat:=xlWhole)
    Set c = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC210", LookIn:=xlValues, lookat:=xlWhole)
    Set d = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC220", LookIn:=xlValues, lookat:=xlWhole)
    If a Is Nothing And b Is Nothing Then
            Sheets("Available sub").Activate
            Range("F" & i) = "Incorrect 1"
    ElseIf a Is Nothing And c Is Nothing Then
        Sheets("Available sub").Activate
        Range("F" & i) = "Incorrect 2"
    ElseIf a Is Nothing And d Is Nothing Then
        Sheets("Available sub").Activate
        Range("F" & i) = "Incorrect 3"
    ElseIf b Is Nothing And c Is Nothing Then
        Sheets("Available sub").Activate
        Range("F" & i) = "Incorrect 4"
     ElseIf b Is Nothing And d Is Nothing Then
        Sheets("Available sub").Activate
        Range("F" & i) = "Incorrect 5"
      ElseIf c Is Nothing And d Is Nothing Then
        Sheets("Available sub").Activate
        Range("F" & i) = "Incorrect 6"
   End If
Next
Next

Please share your thoughts on what the relevant steps are to complete this! Thanks in advance!

1) Do you need the sub to return different results ("Incorrect 1", "Incorrect 2", etc...) for each possibility? 2) Do you need to do this in VBA or would a formula work? — cybernetic.nomad, Jan 07 '20 at 20:35
Your first If statement will exit with an error, even if they have a valid combination of SBC210 and SBC220. Basically, your current code is requiring they have 3 of those listed subjects. Is that intended? — tigeravatar, Jan 07 '20 at 20:36
Side note: you want to [avoid using `Select` and `Activate` in your code](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) — cybernetic.nomad, Jan 07 '20 at 20:37
It doesn't need to return different results e.g. incorrect 1/2 etc, was just for myself to see. It needs to be a sub as it's part of a bigger sub. — Charlotte Hodgson, Jan 07 '20 at 20:38
Nope, can be any combination of only 2 of the listed subjects — Charlotte Hodgson, Jan 07 '20 at 20:39

score 0 · Answer 1 · answered Jan 07 '20 at 20:47

0

If a formula works:

=IF(AND(B1<>B2,COUNTIF(C1:C4,B1)+COUNTIF(C1:C4,B2)=2),"OK","Incorrect")

For some VBA, maybe something like this:

Dim tempstring As String

With Sheets("unknown")
    tempstring = .Range("C1").Value & "|" & .Range("C2").Value & "|" & .Range("C3").Value & "|" & .Range("C4").Value

    If InStr(tempstring, .Range("B1").Value) > 0 And InStr(tempstring, .Range("B2").Value) > 0 Then
        Sheets("Available sub").Range("F1") = "OK"
    Else
        Sheets("Available sub").Range("F1") = "Incorrect"
    End If
End With

Note that you don't qualify the sheets for all you ranges so I used a sheet called "unknown", adjust the code to match you workbook

answered Jan 07 '20 at 20:47

cybernetic.nomad

6,100
3
18
31

Thank you! I'm not quite sure what "B1" and "B2" value are meant to represent and how that determines if it's okay or not if you could explain a bit more! – Charlotte Hodgson Jan 07 '20 at 21:03
I assumed cells `B1` and `B2` (on sheet "unknown") are the cells listing the two subjects are listed in – cybernetic.nomad Jan 07 '20 at 21:16

score 0 · Answer 2 · answered Jan 07 '20 at 20:59

If your Student ID numbers are in column B (change column as needed) you could loop through each Student ID, and Count the number of cells with constants in the range for each row. Your notification can be a message box or color the Student ID interior color red, with this basic macro.

For Each cel In ActiveSheet.Range("B2", Range("B" & Rows.Count).End(xlUp))
    If cel.Resize(, 4).Offset(, 1).SpecialCells(xlCellTypeConstants).Count < 2 Then
        MsgBox "Student " & cel.Text & "did not select two subjects"
        'Or
        cel.Interior.Color = RGB(256, 0, 0)
    End If
Next cel

score 0 · Accepted Answer · answered Jan 07 '20 at 21:29

Here's a generic function that will check a range against a list of values and determine if the quantity of unique values from the provided list is greater than or equal to a desired threshold:

Function CheckUnqValueQty(ByVal arg_rData As Range, ByVal arg_lThreshold As Long, ByVal arg_aValues As Variant) As Boolean

    'This gets the number of unique values listed in arg_aValues found in the arg_rData range
    Dim lEvalResult As Long
    On Error Resume Next    'Suppress errors if any of the arguments were supplied incorrectly or if any of the data cells contain error values
    lEvalResult = Evaluate("SUMPRODUCT(--(COUNTIF(" & arg_rData.Address(External:=True) & ",{""" & Join(arg_aValues, """,""") & """})>0))")
    On Error GoTo 0         'Remove the "On Error Resume Next" condition (no longer suppress errors); if there was an error, lEvalResult will be 0

    'If the eval result is >= the threshold then return True, else False
    CheckUnqValueQty = (lEvalResult >= arg_lThreshold)

End Function

And then you'd call that function from within your loop, like so:

Sub tgr()

    'Define the list of subjects
    Dim aSubjects() As Variant
    aSubjects = Array("SBC130", "SBC150", "SBC210", "SBC220")

    'Define the valid threshold
    Dim lValidQty As Long
    lValidQty = 2

    'Make sure we're working with the correct worksheet
    With ActiveWorkbook.Worksheets("Part B + C Modules")
        'Initiate the loop starting at row 2 and going to last used row
        Dim i As Long
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            'Define the range to check
            Dim rCheck As Range
            Set rCheck = .Range(.Cells(i, "C"), .Cells(i, .Columns.Count).End(xlToLeft))

            'Call the function to check if the appropriate number of different subjects have been selected
            If CheckUnqValueQty(rCheck, lValidQty, aSubjects) = True Then
                'valid result, 2 or more different required subjects selected
                'do something for a valid result here
            Else
                'invalid result, 0 or 1 required subjects selected
                ActiveWorkbook.Worksheets("Available sub").Cells(i, "F").Value = "Incorrect"
            End If
        Next i
    End With

End Sub

VBA - Select any 2 out of 4 options (e.g. 6 combinations) within a greater range of options

3 Answers3