VBA arrays/msg boxes etc

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

The problem description isn't as clear as you might think it is. Please read [mcve]. Have you tried setting breakpoints (F9) and stepping through the code (F8) and inspecting values in the *locals* toolwindow to see where things go awry? — Mathieu Guindon, Sep 24 '18 at 14:23
I think it is mainly down to the placement of the code (perhaps the coding for this bit is also wrong. I think because of the placement of the code, it is doing this as part of the array and so will do it for any row/cell that matches the IF statement. I need it to only do it if every single row fits the above (and not any of the msg(1), msg(2), or msg(3) parts of the array), and so it shouldn't then proceed with the msg(1), msg(2), or msg(3). Is that any better explanation? — N Wally, Sep 24 '18 at 14:31
For one, `msg(4) = MsgBox(...)` means you're storing the result of a `MsgBox` call into subscript 4 of the `msg` array, and that result is going to be the integer representation of `VbMsgBoxResult.vbOk`, ...which is very very likely useless and not what you intended at all, and I don't know what that code is supposed to be doing, nor what you're trying to do. You need to narrow down on a more specific issue. — Mathieu Guindon, Sep 24 '18 at 14:35
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. — N Wally, Sep 24 '18 at 14:45
you can (and should) use the [edit] link below the question to add relevant information and remove parts that aren't useful. It's very difficult to pick important information out of comments. — Cindy Meister, Sep 24 '18 at 15:20
Have done. No one is yet to think of an answer though sadly. — N Wally, Sep 25 '18 at 10:35
Could you provide an example of the data contained in `arr = .Cells(21, 1).Resize(x - 20, 26).Value`. I think it's a logic error with the If then else and select case structure of your code. — Jamie Riis, Sep 25 '18 at 11:20
Please check it here: (sheet 3 contains the code) It also comes up with a random box with "1" in it at the end. (https://www.dropbox.com/s/9m1hx2tylv1k470/SCR%20as%20of%2017%2009%2018%20-%20Copy%20-%20Copy.xlsm?dl=0 — N Wally, Sep 25 '18 at 13:08
Your first sentence says "as long as there is data in 1, 2, and 19", but it is not clear what 1, 2 and 19 are. Would you add some context prior to this sentence, **in the question itself**? Thank you. — halfer, Sep 25 '18 at 16:21

score 0 · Answer 1 · edited Oct 21 '18 at 14:00

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

The declarations for the constants `Public Const NAME_COL as Long = 1` must be placed at the top of the Module, Class or Form Code. They cannot be contained inside a Sub or Function definition. Otherwise you'll get the complier error you're seeing. — Jamie Riis, Sep 26 '18 at 16:06
Yes, please keep your Private functions. They worked fine so I only provided the code I changed or added. — Jamie Riis, Sep 26 '18 at 16:06
It seems to be working well. Just a couple of things may need sorting. Case Else 'Training is missing msg(3) = NoTraining(msg(3), _ arr(x, NAME_COL), _ arr(x, 2), _ arr(x, 18)) — N Wally, Sep 27 '18 at 10:50
At this point, your best bet is to "walk" through your code using the VB Editor's (VBE) debugger. If you are unfamiliar with using the debugger, [Tech on the Net](https://www.techonthenet.com) is a great reference for VBA functions and VBE. Take a look at [MS Excel 2016: VBA Debugging Introduction](https://www.techonthenet.com/excel/macros/vba_debug2016.php). Also another site you should book mark is [Chip Pearson's blog](http://www.cpearson.com/Excel/MainPage.aspx). His search function isn't working but he has a massive amount of sample code available. — Jamie Riis, Sep 27 '18 at 12:24
if the statement `If NoExpiredTraining Then` evaluates to `True`, only one message will appear - showing no upcoming or missing training. The only way that the code executes the `Else` clause is that training is expired, expiring or missing. Take a look at your data source and you might find one of those conditions. — Jamie Riis, Sep 28 '18 at 17:35
Nope, I haven't been ignoring you, I have been incredible busy at work, extending into nights an weekends. I'll take a look today. I noticed that you have duplicate code for each button, you can have several buttons call the same code by placing the working code in Module, rather than code behind on every sheet — Jamie Riis, Oct 08 '18 at 19:33
Thanks, sorry it had been over a week so thought you were! Sadly the column numbers change on different sheets so I don't think using the same code will work. — N Wally, Oct 09 '18 at 07:29
it seems to be working really well, and more efficient than the last one! There's just the odd problem here or there: If there is expired, expiring, or notraining, it always comes up with "Persons with EXPIRED Safeguading Certificates" as the title no matter which one comes up. The EXPIRING box also comes up with anyone that is expired. Also, the date shown for EXPIRED and EXPIRING also needs to be moved one more to the right - it currently shows the start date (column 18) rather than the expiry date (19). Also, if only one should come up, the other two still come up but are blank. — N Wally, Oct 09 '18 at 08:45
So I have managed to get it to find the correct date and use that date. No matter which one for, it was calling the `Expired` function, so I changed the last one to call the `NoTraining` function. When I tried to change the second one to call the `Expiring` function, I get a Compile Error "Argument not optional". This is all under the `For Each Key In trainingDate.Keys` part — N Wally, Oct 09 '18 at 09:13
However, I do still have the problem that if one of them come up, they will all come up - with those that shouldn't come up, coming up blank. Is it possible to add a message into it, so if it were to come up blank, then it could say something like "Everything is okay". I do still have the problem about the second one where it comes up with those expired and expiring, and it doesn't let me change it so it calls the `Expiring` function. — N Wally, Oct 09 '18 at 09:20
Would it also be possible to have a var4 which shows the training level next to each name? Would then make it easier to tell whom needs which type of training? — N Wally, Oct 09 '18 at 09:48
Could it possibly be not liking me changing it to `Expiring` because in the `Expiring` function it doesn't know what the `@d` is meant to be referencing? The `@d` should be the `dDiff` between current date and expiry date. — N Wally, Oct 09 '18 at 09:56
Several possible things for you to investigate using VBE's interactive debugger. 1) don't use variants for all your parameters. You should use a specific data type like integer, string, date, etc. 2) message management, you need to figure out the logic for how to suppress a message if it is essentially blank. 3) use parameter names that mean something, using var1, var2, etc. is bad practice. 4) Since you're writing the code almost anything is possible within the constraints of the environment. 5) rather than guessing try stepping through the code and seeing what is happening. — Jamie Riis, Oct 09 '18 at 11:43
So I have fixed the `Expiring` function call, along with being able to see the dDiff in the message. The last thing needed is something to appear in the box if there is no data to copy over. I have tried `Select Case` for `len(msg)` and an `ElseIF` / `Else`, but I don't seem to be able to figure it out. — N Wally, Oct 09 '18 at 13:52
I'm not sure I understand your question about needing something to appear in the box if there is no data to copy over. Doesn't the section of code under the 'If NoExpiredTraining then` handle that condition? — Jamie Riis, Oct 10 '18 at 18:07
The `NoExpiredTraining` only comes up if none of the `Expiring`, Expired, or `NoTraining` have no data to be pulled through. If there was only an expired date to be pulled through and nothing else, still all three `Expired`, `Expiring` and `NoTraining` will come up. Just `Expiring` and `NoTraining` will then be blank (as there is nothing to pull through. Either way, either just the `NoExpiredTraining` will come up, or all three `Expired`, `Expiring`, and `NoTraining` will always come up (even if one or two of them will hold no data). — N Wally, Oct 11 '18 at 10:49
So I have nearly sorted it with this - see pic of code via the link [https://www.dropbox.com/s/y1ttkh8qdmlod2g/msg.png?dl=0] The only last problem is that the Case number 3 is not picking up the whole thing, unless there is a missing date. In other words, it doesn't display the custom message of `"If this box is blank, there is nothing Missing"` unless there is a date missing. If there are no dates missing, then it picks up the custom message for case number 1 — N Wally, Oct 11 '18 at 13:30

score 0 · Answer 2 · edited Oct 21 '18 at 14:00

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

VBA arrays/msg boxes etc

2 Answers2