Excel宏——返回满足条件的项目列表

Question

我有一个非常简单的 excel 宏，它可以检查单元格范围内是否存在单元格参考范围内的每个值。如果未找到参考范围中的值，则显示未找到该值的消息。然后，用户必须单击“确定”才能继续进行下一项检查。我想修改宏以检查所有值，并在所有检查完成后仅返回未找到的列表。有什么建议吗？

当前代码：

Sub ChkAfternoonAssignmentsV2()
    Dim dayToChk As Variant
    Dim i As Variant
    Dim r As Range
    Dim p As Variant

ReEnter:

    dayToChk = InputBox("Which day (use 3-letter abbreviation) would you like to check afternoon assignments?")
    If dayToChk = "Mon" Then
        Set r = ActiveSheet.Range("MonAft_MA_Slots")
    ElseIf dayToChk = "Tue" Then
        Set r = ActiveSheet.Range("TueAft_MA_Slots")
    ElseIf dayToChk = "Wed" Then
        Set r = ActiveSheet.Range("WedAft_MA_Slots")
    ElseIf dayToChk = "Thu" Then
        Set r = ActiveSheet.Range("ThuAft_MA_Slots")
    ElseIf dayToChk = "Fri" Then
        Set r = ActiveSheet.Range("FriAft_MA_Slots")
    Else
        MsgBox dayToChk & " is not in the expected format.  Try Mon, Tue, Wed, Thu, or Fri."
        GoTo ReEnter
    End If

    Dim AckTime As Integer, InfoBox As Object
    Set InfoBox = CreateObject("WScript.Shell")
    AckTime = 1
    Select Case InfoBox.Popup("Checking MA Assignments", _
    AckTime, "Checking MA Assignments", 0)
    Case 1, -1
    End Select

    For Each i In Sheets("Control").Range("MA_List")
        If WorksheetFunction.CountIf(r, i) < 1 Then
            If i <> "OOO" Then
                MsgBox i & " is not assigned"
            End If
        ElseIf WorksheetFunction.CountIf(r, i) > 1 Then
            If i <> "OOO" Then
                MsgBox i & " is assigned more than once.  Did you really mean to do that?"
            End If
        End If
    Next i

Answer 1

你可以试试这个

Option Explicit

Sub ChkAfternoonAssignmentsV2()
    Dim dayToChk As Variant
    Dim i As Variant
    Dim r As Range
    Dim p As Variant

    Do While r Is Nothing
        dayToChk = InputBox("Which day (use 3-letter abbreviation) would you like to check afternoon assignments?")
        Select Case dayToChk
            Case "Mon", "Tue", "Wed", "Thu", "Fri"
                Set r = ActiveSheet.Range(dayToChk & "Aft_MA_Slots")
            Case Else
                MsgBox "'dayToChk & " ' is not in the expected format.  Try Mon, Tue, Wed, Thu, or Fri."
        End Select
    Loop

    Dim AckTime As Integer, InfoBox As Object
    Set InfoBox = CreateObject("WScript.Shell")
    AckTime = 1
    Select Case InfoBox.Popup("Checking MA Assignments", AckTime, "Checking MA Assignments", 0)
        Case 1, -1
    End Select

    Dim notFounds As String, duplicates As String

    For Each i In Sheets("Control").Range("MA_List")
        If WorksheetFunction.CountIf(r, i) < 1 Then
            If i <> "OOO" Then notFounds = notFounds & i.Value & vbLf
        ElseIf WorksheetFunction.CountIf(r, i) > 1 Then
            If i <> "OOO" Then duplicates = duplicates & i.Value & vbLf
        End If
    Next i

    If notFounds <> "" Then MsgBox "these items have not been found: " & vbCrLf & vbCrLf & notFounds
    If duplicates <> "" Then MsgBox "these items have duplicates: " & vbCrLf & vbCrLf & duplicates

End Sub

Answer 2

已编译但未测试：

Sub ChkAfternoonAssignmentsV2()
    Dim dayToChk As Variant
    Dim i As Variant
    Dim r As Range
    Dim p As Variant
    Dim days, m, sMsg As String, n

    days = Array("Mon", "Tue", "Wed", "Thu", "Fri")

    Do
        dayToChk = InputBox("Which day (Mon, Tue, Wed, Thu, Fri) " & _
                            "would you like to check afternoon assignments?")

        If Len(dayToChk) = 0 Then Exit Sub 'exit if nothing entered

        If IsError(Application.Match(dayToChk, days, 0)) Then
            MsgBox dayToChk & " is not in the expected format.", vbExclamation
        Else
            Set r = ActiveSheet.Range(dayToChk & "Aft_MA_Slots")
        End If
    Loop While r Is Nothing

    'skipping the wscript messagebox code...

    For Each i In Sheets("Control").Range("MA_List")
        If i <> "OOO" Then
            n = WorksheetFunction.CountIf(r, i)
            If n < 1 Then
                sMsg = sMsg & vbLf & i & " is not assigned"
            ElseIf n > 1 Then
                sMsg = sMsg & vbLf & i & " is assigned more than once." & _
                                  "  Did you really mean to do that?"
            End If
        End If
    Next i

    If sMsg <> "" Then
        MsgBox "Some issues were found:" & sMsg, vbExclamation
    End If

End Sub