Excelmacros – 返回满足条件的项目列表

我有一个非常简单的Excelmacros，检查一个单元格的范围内的每个单元格的参考范围内的每个值的存在。 如果没有find来自参考范围的值，则会显示一条消息，指出找不到该值。 然后用户必须点击好的检查才能继续下一个项目。 我想修改macros来检查所有的值，只返回所有检查完成后没有find的列表。 build议？

当前代码：

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

编译但未经testing：

 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