当前，我的数组显示了三个不同的msgbox，如函数“ Expired”，“ Expiring”和“ NoTraining”所示。 msgbox数组根据日期是过期（比当前日期早），过期（在31天之内）和缺少日期（无培训）来显示信息。无论如何，这些数组的msgbox总是会出现，但有时会为空（取决于SELECT CASE语句中的条件）。是否有人知道如何对其进行编码，以便如果msgbox变成空白（如果没有符合标准的条件），则框中将显示不同的消息？我无法使集合和布尔值NoExpiredTraining正常工作，从而调出整个msgbox而不是数组msgboxes，所以我不确定该怎么做。
这是我的代码：
Sub Expire_New()
Dim arr() As Variant
Dim msg(1 To 3) As String
Dim x As Long
Dim nDx As Long
Dim dDiff As Long
LDays = 31
'I would recommend using a named sheet rather than
'ActiveSheet as this can change unexpectedly
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Support Staff")
With ws
x = .Cells(.Rows.Count, TRAINING_DATE_COL).End(xlUp).Row
arr = .Cells(21, 1).Resize(x - 20, 26).Value
End With
'I am a big fan of collections. They make code easier to read
'and to implement. The collection below will be scanned to
'see if there are any training dates that are set to expire within
'30 days or if there are people without any training
Dim colTrainingDate As Collection
Set colTrainingDate = CopyArrDimToCollection(arr, TRAINING_DATE_COL)
'This boolean will be used to control continued flow of the
'macro. If NoExpiredTraining gets set to false, then there
'are people who must complete training.
'Dim NoExpiredTraining As Boolean: NoExpiredTraining = True
For x = LBound(arr, NAME_COL) To UBound(arr, NAME_COL)
'Since every row requires a Name and Surname columns
'to have data in them, let's check this first.
'If a row doesn't have a name then skip it.
If arr(x, NAME_COL) <> "" And arr(x, SURNAME_COL) <> "" Then
'Always good practice to declare your variables/objects
'relevant to where they will be used
'vDx is an index used to loop through the collection of
'Training Dates. This is checking to see if any training
'Dates are empty or less than 31 days from expiration
Dim vDx As Variant
For Each vDx In colTrainingDate
If vDx = "" Then
'blank date means needs training
NoExpiredTraining = False
ElseIf DateDiff("d", Date, vDx) < 31 Then
'less than 31 days means needs training
NoExpiredTraining = False
End If
Next
'At this point you can determine if you want to continue
'If there is no expired training, display the message and exit
'the sub.
If NoExpiredTraining Then
'msg(4) = MsgBox("There are either no ...
'is only used if want to do something based on
'what button the user pressed. Otherwise use
'the Method form of MsgBox
MsgBox "There are either no expired safeguarding certificates, or no certificate expiring within the next 31 days.", vbCritical, "Warning"
Exit Sub
Else
'There is expired training. Let's collect the status
'of each individual
If arr(x, TRAINING_DATE_COL) = "" Then
'if the training date column is empty
'put a really big default value in dDiff
'otherwise you have to trap an error with DateDiff
'and handle it
dDiff = 100
Else
'training date column has a date value
dDiff = DateDiff("d", Date, arr(x, TRAINING_DATE_COL))
End If
'Now let's see what the training status for the person is
Select Case dDiff
Case Is <= 0: 'Training is expired
msg(1) = Expired(msg(1), _
arr(x, NAME_COL), _
arr(x, 2), _
arr(x, TRAINING_DATE_COL))
Case Is <= 31: 'Training is expiring
msg(2) = Expiring(msg(2), _
arr(x, NAME_COL), _
arr(x, 2), _
arr(x, TRAINING_DATE_COL), dDiff)
End Select
If Len(arr(x, 19)) = 0 And Len(arr(x, 1)) > 0 And Len(arr(x, 2)) > 0 Then
msg(3) = NoTraining(msg(3), arr(x, 1), arr(x, 2), arr(x, 18))
End If
End If
End If
Next x
'Because of the Exit Sub statement above, the code bwlow
'will only execute if there are expired, expiring or missing
'training
For x = LBound(msg) To UBound(msg)
msg(x) = Replace(msg(x), "@NL", vbCrLf)
If Len(msg(x)) < 1024 Then
MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
Else
MsgBox "String length for notification too long to fit into this MessageBox", vbExclamation, "Invalid String Length to Display"
End If
Next x
Erase arr
Erase msg
End Sub
'***************************************************************************
'**
'** This fucntion copies all rows of data for the column specified into
'** a collection
Private Function CopyArrDimToCollection(ByRef mMultiDimArray() As Variant, _
ByVal mColumnToCopy As Long) As Collection
Dim retVal As New Collection
Dim nDx As Long
For nDx = LBound(mMultiDimArray, 1) To UBound(mMultiDimArray, 1)
retVal.Add mMultiDimArray(nDx, mColumnToCopy)
Next
Set CopyArrDimToCollection = retVal
End Function
Private Function Expired(ByRef msg As String, ByRef var1 As Variant, ByRef
var2 As Variant, ByRef var3 As Variant) As String
If Len(msg) = 0 Then msg = "Persons with EXPIRED Safeguading
Certificates@NL@NL"
Expired = msg & "(@var3) @var1 @var2@NL"
Expired = Replace(Expired, "@var1", var1)
Expired = Replace(Expired, "@var2", var2)
Expired = Replace(Expired, "@var3", var3)
End Function
Private Function Expiring(ByRef msg As String, ByRef var1 As Variant, ByRef
var2 As Variant, ByRef var3 As Variant, ByRef d As Long) As String
If Len(msg) = 0 Then msg = "Persons with EXPIRING Safeguarding
Certificates@NL@NL"
Expiring = msg & "(@var3) @var1 @var2 (@d days remaining)@NL"
Expiring = Replace(Expiring, "@var1", var1)
Expiring = Replace(Expiring, "@var2", var2)
Expiring = Replace(Expiring, "@var3", var3)
Expiring = Replace(Expiring, "@d", d)
End Function
Private Function NoTraining(ByRef msg As String, ByRef var1 As Variant,
ByRef
var2 As Variant, ByRef var3 As Variant) As String
If Len(msg) = 0 Then msg = "SAFEGUARDING TRAINING NOT COMPLETED FOR @NL@NL"
NoTraining = msg & " @var1 @var2@NL"
NoTraining = Replace(NoTraining, "@var1", var1)
NoTraining = Replace(NoTraining, "@var2", var2)
NoTraining = Replace(NoTraining, "@var3", var3)
End Function