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