VBA - Выберите любые 2 из 4 вариантов (например, 6 комбинаций) в большем диапазоне опций

Question

Существует список идентификаторов с выбранными ими предметами в соответствующей строке. Я пытаюсь написать код, который будет читать предметы и гарантировать, что будут выбраны любые два из четырех выбранных предметов (из 15 предметов), и если это не будет сообщено как ошибка. Необходимыми предметами являются SBC130, SBC150, SBC210 или SBC220, и любая комбинация из 2 подходит из 15 возможных предметов.

Это код, который у меня есть до сих пор

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

Пожалуйста, поделитесь своими мыслями о том, что нужно сделать для этого! Заранее спасибо!

Answer 1

Если ваши студенческие идентификационные номера находятся в столбце B (при необходимости измените столбец), вы можете l oop через каждый Student ID и Count the number of cells with constants в диапазоне для каждой строки. Ваше уведомление может быть красного цвета message box или color the Student ID с этим макросом basi c.

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

Answer 2

Вот обобщенная функция c, которая будет проверять диапазон по списку значений и определять, будет ли количество уникальных значений из предоставленного списка больше или равно желаемому порогу:

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

И тогда вы вызовете эту функцию из вашего l oop, вот так:

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

Answer 3

Если формула работает:

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

Для некоторых VBA может быть что-то вроде этого:

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

Обратите внимание, что вы не квалифицируете листы для всех диапазонов, поэтому я использовал лист с названием «неизвестно», измените код в соответствии с вашей книгой