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