Currently my array brings up three different msgboxes, as shown with the Functions 'Expired', 'Expiring', and 'NoTraining'. The array msgboxes display information based on whether a date is Expired (older than current date), Expiring (within 31 days), and is a date is missing (NoTraining).
No matter what, the msgboxes for the array will always come up, but will sometimes be blank (depending on the criteria in the SELECT CASE statement) and the following IF statement.
Does anyone know anyway of coding it so that if the msgboxes were to come up blank (if nothing fits the criteria), a different message will be shown in the box? I can't get the collection and boolean NoExpiredTraining to work properly bringing up an overall msgbox instead of the array msgboxes, so I need a message to appear in the Private Functions if there isn't going to be any data in the boxes (i.e. if the box would come up blank, then a "Everything okay" message)
This is my code:
No matter what, the msgboxes for the array will always come up, but will sometimes be blank (depending on the criteria in the SELECT CASE statement) and the following IF statement.
Does anyone know anyway of coding it so that if the msgboxes were to come up blank (if nothing fits the criteria), a different message will be shown in the box? I can't get the collection and boolean NoExpiredTraining to work properly bringing up an overall msgbox instead of the array msgboxes, so I need a message to appear in the Private Functions if there isn't going to be any data in the boxes (i.e. if the box would come up blank, then a "Everything okay" message)
This is my code:
Code:
[/FONT][/COLOR]
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
NL@NL"
