В настоящее время мой массив отображает три разных сообщения, как показано в функциях «Истек», «Истекает» и «NoTraining».Массив msgbox отображает информацию, основанную на том, истекла ли дата (более старая, чем текущая дата), истекает (в течение 31 дня) и является ли дата отсутствующей (NoTraining).Независимо от того, что эти msgboxes для массива всегда будут появляться, но иногда будут пустыми (в зависимости от критериев в инструкции SELECT CASE).Кто-нибудь знает в любом случае о его кодировании так, чтобы, если бы msgbox были пустыми (если ничто не соответствует критериям), в поле будет показано другое сообщение?Я не могу заставить коллекцию и логическое NoExpiredTraining работать правильно, вызывая общий msgbox вместо массива msgbox, поэтому я не уверен, что делать.
Это мой код:
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