VBA arrays/msg boxes etc - arrays

Question

I need a msgbox to appear if nothing has expired, is expiring, and as long as there is data in 1, 2, and 19. Currently it displays it for anyone fitting the above, but it should only come up if every single row fits the above. It should then reject the other msgboxes from coming up.
Please see all the code below.
Sub Expire_New()
Dim arr() As Variant
Dim msg(1 To 4) As String
Dim x As Long
Dim dDiff As Long
With ActiveSheet
x = .Cells(.Rows.Count, 19).End(xlUp).Row
arr = .Cells(21, 1).Resize(x - 20, 26).Value
End With
For x = LBound(arr, 1) To UBound(arr, 1)
If Len(arr(x, 19)) * Len(arr(x, 1)) * Len(arr(x, 2)) Then
dDiff = DateDiff("d", Date, arr(x, 19))
Select Case dDiff
Case Is <= 0: msg(1) = Expired(msg(1), arr(x, 1), arr(x, 2), arr(x, 19))
Case Is <= 31: msg(2) = Expiring(msg(2), arr(x, 1), arr(x, 2), arr(x, 19), dDiff)
End Select
End If
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
If Len(arr(x, 19)) > 0 And Len(arr(x, 1)) > 0 And Len(arr(x, 2)) > 0 Then
dDiff = DateDiff("d", Date, arr(x, 19))
Select Case dDiff
Case Is > 31: msg(4) = MsgBox("There are either no expired safeguarding certificates, or no certificate expiring within the next 31 days.", vbCritical, "Warning")
End Select
End If
Next x
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
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
I think it is the part below causing the problem. I don't think this should be in the main array?
If Len(arr(x, 19)) > 0 And Len(arr(x, 1)) > 0 And Len(arr(x, 2)) > 0 Then
dDiff = DateDiff("d", Date, arr(x, 19))
Select Case dDiff
Case Is > 31: msg(4) = MsgBox("There are either no expired safeguarding certificates, or no certificate expiring within the next 31 days.", vbCritical, "Warning")
End Select
End If
So what I effectively want with "msg(4)" is that I want this to come up only if the criteria for msg(1), msg(2), and msg(3) are not matched. If msg(4) comes up, then the other 3 msg should not. msg1 finds any row/cell where the date listed is older than the current date. msg2 finds the row/cell where the current date is within 31 days of the date listed. msg3 finds the row/cell where there is no date listed, but where there is a name in column 1 or 2. So if the date listed (in cell in column 19) is more than 31 days, and there is a name in 1 and 2, then msg4 should come up and not 1, 2, or 3. 1 and 2 contain names, and 19 contains a date.
Code is on sheet 3 here: https://www.dropbox.com/s/9m1hx2tylv1k470/SCR%20as%20of%2017%2009%2018%20-%20Copy%20-%20Copy.xlsm?dl=0

Answer 1

Public Sub Expire_New(ByRef ws As Worksheet, ByVal Name As String)
Dim msg(1 To 3) As String
Dim x As Long
Dim nDx As Long
Dim dDiff As Long
'Establish the location of the first cell (range) of the Safegaurding Training block
'Find the first instance of Safeguarding Training on the sheet
Dim sgTrainingCol As Range
With ws.Range("A1:AA1000") 'Using something large to provide a range to search
Set sgTrainingCol = .Find("Safeguarding Training", LookIn:=xlValues)
End With
'Establish the location of the first cell (range) of the heading column
'for the table on the sheet. Find the first instance of what is contained
'in mTitleFirstHeadingColumn
Dim HeadingRangeStart As Range
With ws.Range("A1:AA1000") 'Using something large to provide a range to search
Set HeadingRangeStart = .Find(Name, LookIn:=xlValues)
End With
Dim TrainingInfoRange As Range
Dim personFNSR As Range
With ws
'finds the last row of the Heading column that has data, there can NOT be any empty rows
'in the middle of this search. It assumes that the name column date is contigous until
'reaching the end of the data set.
x = .Cells(HeadingRangeStart.Row, HeadingRangeStart.Column).End(xlDown).Row
'Set the TrainingInfoRange to point to the data contained in the 4 columns under Safeguarding Training
Set TrainingInfoRange = .Range(.Cells(sgTrainingCol.Row + 2, sgTrainingCol.Column), .Cells(x, sgTrainingCol.Column + 3))
'Set pseronFNSR to the First Name/Name, Surname range
Set personFNSR = .Range(.Cells(HeadingRangeStart.Row + 1, HeadingRangeStart.Column), .Cells(x, HeadingRangeStart.Column + 1))
End With
'I am a big fan of collections and scripting dictionaries.
'They make code easier to read and to implement.
Dim trainingDate As Scripting.Dictionary
Set trainingDate = CopyRngDimToCollection(personFNSR, TrainingInfoRange)
'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
'person training inquiry object - see class definition
Dim personInquiryTraining As clPersonTraining
'this is an index variable used to loop through items
'contained in the Scripting Dictionary object
Dim Key As Variant
For Each Key In trainingDate.Keys
'Assing the next object in the trainingDate Scripting Dictionary
'to the person training inquiry object
Set personInquiryTraining = trainingDate(Key)
'Check to see if there are any training issues
'if so, then set NoExpiredTraining to False
'because there is expired, expiring or missing training
If personInquiryTraining.ExpiringTraining _
Or personInquiryTraining.NoTraining _
Or personInquiryTraining.TrainingExpired Then
NoExpiredTraining = False
End If
Next
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
End If
'If this code executes, then there is expired training.
'Let's collect the status for each individual
For Each Key In trainingDate.Keys
Set personInquiryTraining = trainingDate(Key)
If personInquiryTraining.TrainingExpired _
And personInquiryTraining.trainingDate <> DateSerial(1900, 1, 1) Then 'Training
is expired
msg(1) = Expired(msg(1), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
personInquiryTraining.trainingExpiryDate)
End If
If personInquiryTraining.ExpiringTraining _
And personInquiryTraining.trainingExpiryDate <> DateSerial(1900, 1, 1) Then
'Training is expiring
msg(2) = Expiring(msg(2), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
personInquiryTraining.trainingExpiryDate, _
DateDiff("d", Date, personInquiryTraining.trainingExpiryDate))
End If
If personInquiryTraining.NoTraining Then 'Training is None
msg(3) = NoTraining(msg(3), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
"NONE")
End If
Next
'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
Select Case msg(x)
Case msg(1)
If Len(msg(x)) & vbNullString > 0 Then
'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf
& msg(x), vbExclamation, "Safeguarding Certificate Notification"
MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
End If
Case msg(2)
If Len(msg(x)) & vbNullString > 0 Then
'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf
& msg(x), vbExclamation, "Safeguarding Certificate Notification"
MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
End If
Case msg(3)
If Len(msg(x)) & vbNullString > 0 Then
'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf
& msg(x), vbExclamation, "Safeguarding Certificate Notification"
MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
End If
End Select
Else
MsgBox "String length for notification too long to fit into this MessageBox",
vbExclamation, "Invalid String Length to Display"
End If
Next x
End Sub
'***************************************************************************
'**
'** This fucntion copies all rows of data for the column specified into
'** a scripting dictionary
Private Function CopyRngDimToCollection(ByRef mFNSR As Range, ByRef mTrainInfo) As
Scripting.Dictionary
Dim retVal As New Scripting.Dictionary
'nDx will become a key for each of the scripting dictionary items
Dim nDx As Long: nDx = 1
'person training inquiry object - see class definition
Dim personTraining As clPersonTraining
Dim mRow As Range
For Each mRow In mFNSR.Rows
'instantiate a new person training inquiry object
Set personTraining = New clPersonTraining
With personTraining
.firstName = mRow.Value2(1, 1)
.surName = mRow.Value2(1, 2)
End With
retVal.Add nDx, personTraining
nDx = nDx + 1
Next
nDx = 1
For Each mRow In mTrainInfo.Rows
'Retrieve the person training inquiry object
'from the scripting dictionary (retVal)
Set personTraining = retVal(nDx)
'Add the training data information to
'the person training inquiry object
With personTraining
'Next two equations determine if the excel range has a null value
'if so then the person training inquiry object's date field is set to a
'default value of 1-1-1900 - this could be any valid date
'otherwise the value is set to what is in the excel range from the sheet
.trainingDate = IIf(mRow.Value2(1, 1) = vbNullString, DateSerial(1900, 1, 1),
mRow.Value2(1, 1))
.trainingExpiryDate = IIf(mRow.Value2(1, 2) = vbNullString, DateSerial(1900,
1, 1), mRow.Value2(1, 2))
.trainingLevel = mRow.Value2(1, 3)
.certSeenBy = mRow.Value2(1, 4)
End With
'Update the object stored at the current key location
'given by the value of nDx
Set retVal(nDx) = personTraining
nDx = nDx + 1
Next
'Set the return value for the function
Set CopyRngDimToCollection = 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 & "#var1 #var2 (#var3)#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 & "#var1 #var2 (#var3) (#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
and
Option Explicit
Public firstName As String
Public surName As String
Public trainingDate As Date
Public trainingExpiryDate As Date
Public trainingLevel As String
Public certSeenBy As String
Public dDiff As Long
Public Property Get TrainingExpired() As Boolean
If DateDiff("d", Date, trainingExpiryDate) <= 0 Then
TrainingExpired = True
Else
TrainingExpired = False
End If
End Property
Public Property Get ExpiringTraining() As Boolean
If DateDiff("d", Date, trainingExpiryDate) > 0 Then
dDiff = DateDiff("d", Date, trainingExpiryDate)
Select Case dDiff
Case Is <= 31
ExpiringTraining = True
Case Else
ExpiringTraining = False
End Select
End If
End Property
Public Property Get NoTraining() As Boolean
If trainingDate = DateSerial(1900, 1, 1) Then
NoTraining = True
Else
NoTraining = False
End If
End Property

Answer 2

After looking at your decision statements, the issue was with your logic. In the code below I cleaned up the logic. The inline comments explain what was done. After looking at your workbook in more detail, you're mixing what should be a database application producing reports, with a report you're trying to treat as a database. People do this all the time. Most people write the report in Excel and then try to do analytics or database actions.
You should consider standardizing all of your tables and using Excel Tables which are ListObjects.
I also used the Scripting Dictionary add-in from Microsoft. You must add this to your workbook references. In the VBE click on the Tools menu item and then click on References. (Tools->Reference). Once the dialog box appears scroll down until you find Microsoft Scripting Runtimes. Click on the check box and then click Ok.
You will also need to change the code on the worksheets. You can delete everything there and replace it with
'In this case use of the ActiveSheet
'is ok since the button pressed
'is on the ActiveSheet
Expire_New ActiveSheet, "First Name"
Note, the second parameter of the Expire_New subroutine, must reflect the title you used on each sheet for persons first name in column A.
Option Explicit
'**************************************************************************
'**
'** This sub takes two parameters:
'** ws as Worksheet is the Worksheet object passed from the calling
'** routine
'** mTitleFirstHeadingColumn as string is the title of the first column
'** in the training table on every sheet. THis was added because
'** on one sheet the value is First Name on other sheets it's Name
Public Sub Expire_New(ByRef ws As Worksheet, ByVal mTitleFirstHeadingColumn As String)
Dim msg(1 To 3) As String
Dim x As Long
Dim nDx As Long
Dim dDiff As Long
'Establish the location of the first cell (range) of the Safegaurding Training block
'Find the first instance of Safeguarding Training on the sheet
Dim sgTrainingCol As Range
With ws.Range("A1:AA1000") 'Using something large to provide a range to search
Set sgTrainingCol = .Find("Safeguarding Training", LookIn:=xlValues)
End With
'Establish the location of the first cell (range) of the heading column
'for the table on the sheet. Find the first instance of what is contained
'in mTitleFirstHeadingColumn
Dim HeadingRangeStart As Range
With ws.Range("A1:AA1000") 'Using something large to provide a range to search
Set HeadingRangeStart = .Find(mTitleFirstHeadingColumn, LookIn:=xlValues)
End With
Dim TrainingInfoRange As Range
Dim personFNSR As Range
With ws
'finds the last row of the Heading column that has data, there can NOT be any empty rows
'in the middle of this search. It assumes that the name column date is contigous until
'reaching the end of the data set.
x = .Cells(HeadingRangeStart.Row, HeadingRangeStart.Column).End(xlDown).Row
'Set the TrainingInfoRange to point to the data contained in the 4 columns under Safeguarding Training
Set TrainingInfoRange = .Range(.Cells(sgTrainingCol.Row + 2, sgTrainingCol.Column), .Cells(x, sgTrainingCol.Column + 3))
'Set pseronFNSR to the First Name/Name, Surname range
Set personFNSR = .Range(.Cells(HeadingRangeStart.Row + 1, HeadingRangeStart.Column), .Cells(x, HeadingRangeStart.Column + 1))
End With
'I am a big fan of collections and scripting dictionaries.
'They make code easier to read and to implement.
Dim trainingDate As Scripting.Dictionary
Set trainingDate = CopyRngDimToCollection(personFNSR, TrainingInfoRange)
'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
'person training inquiry object - see class definition
Dim personInquiryTraining As clPersonTraining
'this is an index variable used to loop through items
'contained in the Scripting Dictionary object
Dim Key As Variant
For Each Key In trainingDate.Keys
'Assing the next object in the trainingDate Scripting Dictionary
'to the person training inquiry object
Set personInquiryTraining = trainingDate(Key)
'Check to see if there are any training issues
'if so, then set NoExpiredTraining to False
'because there is expired, expiring or missing training
If personInquiryTraining.ExpiringTraining _
Or personInquiryTraining.NoTraining _
Or personInquiryTraining.TrainingExpired Then
NoExpiredTraining = False
End If
Next
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
End If
'If this code executes, then there is expired training.
'Let's collect the status for each individual
For Each Key In trainingDate.Keys
Set personInquiryTraining = trainingDate(Key)
If personInquiryTraining.TrainingExpired _
And personInquiryTraining.trainingDate <> DateSerial(1900, 1, 1) Then 'Training is expired
msg(1) = Expired(msg(1), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
personInquiryTraining.trainingDate)
End If
If personInquiryTraining.ExpiringTraining _
And personInquiryTraining.trainingExpiryDate <> DateSerial(1900, 1, 1) Then 'Training is expiring
msg(2) = Expired(msg(2), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
personInquiryTraining.trainingDate)
End If
If personInquiryTraining.NoTraining Then 'Training is None
msg(3) = Expired(msg(3), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
"NONE")
End If
Next
'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
End Sub
'***************************************************************************
'**
'** This fucntion copies all rows of data for the column specified into
'** a scripting dictionary
Private Function CopyRngDimToCollection(ByRef mFNSR As Range, ByRef mTrainInfo) As Scripting.Dictionary
Dim retVal As New Scripting.Dictionary
'nDx will become a key for each of the scripting dictionary items
Dim nDx As Long: nDx = 1
'person training inquiry object - see class definition
Dim personTraining As clPersonTraining
Dim mRow As Range
For Each mRow In mFNSR.Rows
'instantiate a new person training inquiry object
Set personTraining = New clPersonTraining
With personTraining
.firstName = mRow.Value2(1, 1)
.surName = mRow.Value2(1, 2)
End With
retVal.Add nDx, personTraining
nDx = nDx + 1
Next
nDx = 1
For Each mRow In mTrainInfo.Rows
'Retrieve the person training inquiry object
'from the scripting dictionary (retVal)
Set personTraining = retVal(nDx)
'Add the training data information to
'the person training inquiry object
With personTraining
'Next two equations determine if the excel range has a null value
'if so then the person training inquiry object's date field is set to a
'default value of 1-1-1900 - this could be any valid date
'otherwise the value is set to what is in the excel range from the sheet
.trainingDate = IIf(mRow.Value2(1, 1) = vbNullString, DateSerial(1900, 1, 1), mRow.Value2(1, 1))
.trainingExpiryDate = IIf(mRow.Value2(1, 2) = vbNullString, DateSerial(1900, 1, 1), mRow.Value2(1, 2))
.trainingLevel = mRow.Value2(1, 3)
.certSeenBy = mRow.Value2(1, 4)
End With
'Update the object stored at the current key location
'given by the value of nDx
Set retVal(nDx) = personTraining
nDx = nDx + 1
Next
'Set the return value for the function
Set CopyRngDimToCollection = 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
You will also need to add a class to your workbook. In the VB Editor window, click on Insert->Class Module. When that has been added, change the name of the class to clPersonTraining. And paste the following code into that class:
Option Explicit
Public firstName As String
Public surName As String
Public trainingDate As Date
Public trainingExpiryDate As Date
Public trainingLevel As String
Public certSeenBy As String
Public Property Get TrainingExpired() As Boolean
If DateDiff("d", Date, trainingExpiryDate) < 1 Then
TrainingExpired = True
Else
TrainingExpired = False
End If
End Property
Public Property Get ExpiringTraining() As Boolean
If DateDiff("d", Date, trainingExpiryDate) < 31 Then
ExpiringTraining = True
Else
ExpiringTraining = False
End If
End Property
Public Property Get NoTraining() As Boolean
If trainingDate = DateSerial(1900, 1, 1) Then
NoTraining = True
Else
NoTraining = False
End If
End Property
It's very simple class that provides the answers. For more information about VBA Classes, I recommend getting a book on the VBA programming language. It will cover the topic in much better detail than possible here