Same array/msgbox to display different messages - arrays

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, these msgboxes for the array will always come up, but will sometimes be blank (depending on the criteria in the SELECT CASE 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 am unsure what to do.
This is my code:
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

Related

Loop through array and return multiple rows based on one or more search criteria

I am looping through ArrayDestination through two columns (customer name and process number).
I am looping through ArraySourceData to find matches (invoice number and amount) for the above search criteria.
If there is a match it gets copied to the array and once both loops finish the results get copied to the worksheet.
So far it works except that the loop is only returning the first match.
If a customer has multiple identical process numbers the loop only returns the first match for all of them.
My b variable looks a bit static and I tried to cheer it up with b = b + 1.
For simplicity I didn't post creating the array part. It works. If needed I can provide it.
Sub search_loop_arrray()
For a = 2 To UBound(ArraySourceData)
varCustomerName = ArraySourceData(a, 3)
varProcessNumber = ArraySourceData(a, 5)
For b = 2 To UBound(ArrayDestination)
If ArrayDestination(b, 3) = varCustomerName And _
ArrayDestination(b, 8) = varProcessNumber Then
ArrayDestination(b, 9) = ArraySourceData(a, 11)
ArrayDestination(b, 10) = ArraySourceData(a, 12)
Exit For
End If
Next b
Next a
'transfer data (invoice number and amount) from ArrayDestination to wsDestination (Column 9 and 10)
For a = 2 To UBound(ArraySourceData)
For b = 9 To 10
wsDestination.Cells(a, b).Value = ArrayDestination(a, b)
Next b
Next a
End Sub
02/02/2020
I rewrote the code in a nested for loop without the array. This code works. The problem is there are duplicated process numbers in my source data.
In my example I "cut and paste" the already found process numbers in a sheet called coincidences. It is working BUT I was looking to parse everything into an array due to dealing with 100.000+ rows and 20+ columns.
I don't know if my "copy to temporary coincidences sheet" would make sense in the array?
Sub find_invoice()
Dim wsSourceData As Worksheet
Dim wsResults As Worksheet
Dim wsCoincidences As Worksheet
Dim varCustomer As String
Dim varProcessNumber As Long
Dim varInvoiceNumber As Long
Dim varSDlastrow As Integer
Dim varRElastrow As Long
Dim varCIlastrow As Long
Dim varCounterResults As Long
Set wsResults = ThisWorkbook.Sheets("RESULTS")
Set wsSourceData = ThisWorkbook.Sheets("SOURCEDATA")
Set wsCoincidences = ThisWorkbook.Sheets("COINCIDENCES")
varSDlastrow = wsSourceData.Cells(Rows.Count, 1).End(xlUp).Row
varRElastrow = wsResults.Cells(Rows.Count, 1).End(xlUp).Row
varCIlastrow = wsCoincidences.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To varRElastrow
varCustomer = wsResults.Cells(i, 1)
varProcessNumber = wsResults.Cells(i, 2)
For j = 2 To varSDlastrow
If wsSourceData.Cells(j, 1) = varCustomer And wsSourceData.Cells(j, 2) = varProcessNumber Then
wsResults.Cells(i, 3) = wsSourceData.Cells(j, 3)
wsResults.Cells(i, 4) = wsSourceData.Cells(j, 4)
wsCoincidences.Rows(varCIlastrow).EntireRow.Value = wsSourceData.Rows(j).EntireRow.Value
wsSourceData.Rows(j).EntireRow.Delete
varCIlastrow = varCIlastrow + 1
Exit For
End If
Next j
Next i
End Sub
I'm not sure you're logic is right. If you are saying you need to match 2 parameters and several entities can contain those two parameters, then I don't see how you can do anything other than find either the first or last occurrence. Wouldn't you need a third parameter to distinguish the matches?
You'll see in the sample code below, I've assumed that the source data has the list of invoices which are sequential and the destination data has the duplicate customer and process parameters. In this case I've assumed that the invoice matching on the destination sheet should also be sequential, ie 2nd occurrence of duplicate means match the 2nd occurence of an invoice. So here, 'sequence' becomes the third parameter, but yours may be different.
It might also be easier to format your data into a hierarchical structure:
customer -> process -> invoice
so you can see what's going on a little easier. Classes are ideal for this. Your code is hard to follow as that Exit For will guarantee a first match only, and the transfer loop iterates on the upperbound of the ArraySourceData array and yet processes the ArrayDestination (I can't see what you're trying to do there, unless it's an error).
To show you what I mean, create three classes (Insert~>Class Module) called cCustomer, cProcess and cInvoice. Add the following code to each:
cCustomer
Option Explicit
Public Name As String
Public Processes As Collection
Public Sub AddInvoice(processNum As String, invoiceNum As String, invAmount As Double)
Dim process As cProcess
Dim invoice As cInvoice
On Error Resume Next
Set process = Processes(processNum)
On Error GoTo 0
If process Is Nothing Then
Set process = New cProcess
With process
.ProcessNumber = processNum
Processes.Add process, .ProcessNumber
End With
End If
Set invoice = New cInvoice
With invoice
.InvoiceNumber = invoiceNum
.Amount = invAmount
process.Invoices.Add invoice
End With
End Sub
Public Function GetProcess(num As String) As cProcess
On Error Resume Next
Set GetProcess = Processes(num)
End Function
Private Sub Class_Initialize()
Set Processes = New Collection
End Sub
cProcess
Option Explicit
Public ProcessNumber As String
Public Invoices As Collection
Public CurrentInvoiceCount As Long
Private Sub Class_Initialize()
Set Invoices = New Collection
End Sub
cInvoice
Option Explicit
Public InvoiceNumber As String
Public Amount As Double
Public ArrayIndex As Long
The following routine in your Module will output the data as I described above:
Dim customers As Collection
Dim customer As cCustomer
Dim process As cProcess
Dim invoice As cInvoice
Dim srcData As Variant, dstData As Variant
Dim output() As Variant
Dim i As Long
'Populate the source data array.
'Note: just an example here, use whatever array populating code you have.
With Sheet1 'I've put some dummy data in my Sheet1.
srcData = _
.Range( _
.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, 12) _
.Value2
End With
'Populate the destination data array.
'Note: just an example here, use whatever array populating code you have.
With Sheet2 'I've put some dummy data in my Sheet2.
dstData = _
.Range( _
.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, 10) _
.Value2
End With
'Convert source array to heirarchical collections.
Set customers = New Collection
For i = 1 To UBound(srcData, 1)
Set customer = Nothing: On Error Resume Next
Set customer = customers(CStr(srcData(i, 3))): On Error GoTo 0
If customer Is Nothing Then
Set customer = New cCustomer
With customer
.Name = CStr(srcData(i, 3))
customers.Add customer, .Name
End With
End If
customer.AddInvoice CStr(srcData(i, 5)), CStr(srcData(i, 11)), CDbl(srcData(i, 12))
Next
'Match destination array.
For i = 1 To UBound(dstData, 1)
Set customer = Nothing: On Error Resume Next
Set customer = customers(CStr(dstData(i, 3))): On Error GoTo 0
If Not customer Is Nothing Then
Set process = customer.GetProcess(CStr(dstData(i, 8)))
If Not process Is Nothing Then
With process
.CurrentInvoiceCount = .CurrentInvoiceCount + 1
If .CurrentInvoiceCount > .Invoices.Count Then
MsgBox "No further invoices for [cust=" & customer.Name & ";" & process.ProcessNumber & "]"
Else
Set invoice = .Invoices(.CurrentInvoiceCount)
invoice.ArrayIndex = i
End If
End With
End If
End If
Next
'Populate the output array.
ReDim output(1 To UBound(dstData, 1), 1 To 2)
For Each customer In customers
For Each process In customer.Processes
For Each invoice In process.Invoices
With invoice
If .ArrayIndex > 0 Then
output(.ArrayIndex, 1) = .InvoiceNumber
output(.ArrayIndex, 2) = .Amount
End If
End With
Next
Next
Next
'Write array to worksheet
Sheet2.Cells(2, 9).Resize(UBound(output, 1), UBound(output, 2)).Value = output
Without seeing some sample data, it's difficult to be certain, but I suspect my point is: if only a combination of three of parameters makes something unique, then you'll need to match against those three parameters.
If you have 100,000 rows on the SOURCEDATA sheet and 10,000 rows of the RESULTS sheet then having 2 loops is 1,000,000,000 iterations. The efficient way is to use a dictionary object using a key constructed on your 2 match criteria (col1 and col2) joined by a character of your choice such a "~" (tilde) or "_" (underscore). Scan the SOURCEDATA sheet once to build a "look up" of key to row number. Then scan the RESULTS sheet once, concatenate the 2 fields as before and using the dictionary .exists(key) method to find a match will give you the relevant row number on SOURCEDATA. Here is some code to illustrate. I tested it with 100,000 source rows and 10,000 results rows of random data matching the keys and filling in col C and D on the RESULTS sheet take around 3 seconds. Add a sheet called RUNLOG for the performance figures. It looks a lot of code but much of it is logging.
Option Explicit
Sub find_invoice2()
Const MSG As Boolean = False ' TRUE to show message boxes
Const RUNLOG As Boolean = False ' TRUE to log matches, no match etc
Dim wb As Workbook, start As Single, finish As Single
start = Timer
Set wb = ThisWorkbook
' set up sheets
Dim wsSourceData As Worksheet, wsResults As Worksheet, wsLog As Worksheet, wsMatch
With wb
Set wsResults = .Sheets("RESULTS")
Set wsSourceData = .Sheets("SOURCEDATA")
Set wsMatch = .Sheets("COINCIDENCES")
Set wsLog = .Sheets("RUNLOG")
End With
' find last row of source and results
Dim lastRowSource As Long, lastRowResults As Long, lastRowLog As Long, lastRowMatch
lastRowSource = wsSourceData.Cells(Rows.Count, 1).End(xlUp).Row
lastRowResults = wsResults.Cells(Rows.Count, 1).End(xlUp).Row
lastRowMatch = wsMatch.Cells(Rows.Count, 1).End(xlUp).Row
' set up log sheets
wsLog.Cells.Clear
wsLog.Range("A1:E1") = Array("Source Row", "Result Row", "Customer~Process", "Message", "Date Time")
wsLog.Cells(2, 4) = "Started"
wsLog.Cells(2, 5) = Time
lastRowLog = 3
' create lookup from Source
' key = Name~ProcessID, value = array row
Dim dict As Object, sKey As String, iRow As Long
Set dict = CreateObject("scripting.dictionary")
With wsSourceData
For iRow = 2 To lastRowSource
sKey = CStr(.Cells(iRow, 1)) & "~" & CStr(.Cells(iRow, 2)) ' customer~process
If Len(sKey) > 1 Then ' skip blanks lines if any
If dict.exists(sKey) Then
dict.Item(sKey) = dict.Item(sKey) & "_" & CStr(iRow)
If MSG Then MsgBox "Ignoring duplicate key in Source Data " & sKey, vbCritical
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 0) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Source : Ignoring duplicate key "
.Offset(0, 4) = Time
End With
lastRowLog = lastRowLog + 1
End If
Else
dict.Add sKey, iRow
'Debug.Print "Dict add", sKey, iRow
End If
End If
Next
End With
If MSG Then MsgBox dict.Count & " records added to dictionary"
wsLog.Cells(lastRowLog, 4) = "Dictionary Built Keys Count = " & dict.Count
wsLog.Cells(lastRowLog, 5) = Time
lastRowLog = lastRowLog + 1 ' blank line to seperate results
' scan results sheet
Dim sDict As String, countMatch As Long, countNoMatch As Long, sMsg As String
Dim ar As Variant, i As Long
countMatch = 0: countNoMatch = 0
Application.ScreenUpdating = False
With wsResults
For iRow = 2 To lastRowResults
sKey = CStr(.Cells(iRow, 1)) & "~" & CStr(.Cells(iRow, 2)) ' customer~process
If Len(sKey) > 1 Then 'skip blanks lines if any
If dict.exists(sKey) Then
' split string to get multiple lines
sDict = dict(sKey)
ar = Split(sDict, "_")
.Cells(iRow, 3).Value = UBound(ar) + 1
For i = 0 To UBound(ar)
.Cells(iRow, 4).Offset(0, i) = ar(i)
Next
lastRowMatch = lastRowMatch + 1
countMatch = countMatch + 1
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 0) = sDict
.Offset(0, 1) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Match - Source record deleted"
.Offset(0, 4) = Time
End With
lastRowLog = lastRowLog + 1
End If
'Debug.Print iRow,sDict, sKey,
Else
' no match
If MSG Then MsgBox "Results Row " & iRow & ": NO match for " & sKey, vbExclamation, "NO match"
countNoMatch = countNoMatch + 1
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 1) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Results : NO match"
.Offset(0, 4) = Time
.EntireRow.Interior.Color = vbYellow
End With
.Cells(iRow, 3).Resize(1, 2).Interior.Color = vbYellow
lastRowLog = lastRowLog + 1
'Debug.Print iRow, sDict, sKey,
End If
End If
End If
Next
End With
Application.ScreenUpdating = True
wsLog.Cells(lastRowLog, 4) = "Program Ended Rows Scanned = " & lastRowResults - 1
wsLog.Cells(lastRowLog, 5) = Time
wsLog.Columns.AutoFit
wsLog.Activate
wsLog.Columns("A:B").HorizontalAlignment = xlCenter
wsLog.Range("A1").Select
' result
finish = Timer
sMsg = "Matched = " & countMatch & vbCrLf _
& "NO match = " & countNoMatch & vbCrLf _
& "Run time (secs) = " & Int(finish - start)
MsgBox sMsg, vbInformation, "Results"
End Sub

VBA array write to .txt file

I am having problems getting my array to write to a txt.file correctly.
What it does currently, is display the results in a msgbox so we can see it straight away, and writes only some of the data that appeared in that msgbox into the txt.file.
I tried using 'Append' which does display all the data, but of course, it only adds the data to the txt.file rather than replacing what is already in there.
'Output' I think is the only way of getting it to write all the data into the txt.file, and then also replace it each time.
Sadly, I cannot get it to work with 'output'. It currently only writes the last line of data that was in the array.
I assume I need some kind of loop, but I cannot figure out a way to get it to work successfully.
My code is below. Any help would be appreciated.
Private Function Expired(ByRef msg As String, ByRef var1 As Variant, ByRef
var2 As Variant, ByRef var3 As Variant) As String
Dim sFilePath As String
Dim FileNumber
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)
sFilePath = "R:\HR and Admin\Expired.txt"
FileNumber = FreeFile
If (VBA.Len(VBA.Dir(sFilePath))) = 0 Then MsgBox "File Does not exists": End
Open sFilePath For Output As #FileNumber
Print #FileNumber , var1, var2, var3
Close #FileNumber
The following is all the code for the vba sheet:
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.", _
vbInformation, "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), vbCritical, "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), vbCritical, "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
Dim sFilePath As String
Dim FileNumber
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)
sFilePath = "R:\HR and Admin\Expired.txt"
FileNumber = FreeFile
If (VBA.Len(VBA.Dir(sFilePath))) = 0 Then MsgBox "File Does not exists":
End
Open sFilePath For Output As #FileNumber
Print #FileNumber, var1, var2, var3
Close #FileNumber
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
Dim sFilePath As String
Dim FileNumber
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)
sFilePath = "R:\HR and Admin\Expiring.txt"
FileNumber = FreeFile
If (VBA.Len(VBA.Dir(sFilePath))) = 0 Then MsgBox "File Does not exists":
End
Open sFilePath For Output As #FileNumber
Print #FileNumber, var1, var2, var3
Close #FileNumber
End Function
Private Function NoTraining(ByRef msg As String, ByRef var1 As Variant,
ByRef var2 As Variant, ByRef var3 As Variant) As String
Dim sFilePath As String
Dim FileNumber
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)
sFilePath = "R:\HR and Admin\NoTraining.txt"
FileNumber = FreeFile
If (VBA.Len(VBA.Dir(sFilePath))) = 0 Then MsgBox "File Does not exists":
End
Open sFilePath For Output As #FileNumber
Print #FileNumber, var1, var2, var3
Close #FileNumber
End Function
You need to open the file once instead of looping over the file open. The easiest way to change your existing code is to open all 3 files before you start the loop, and then close them when you're done. Then pass the open file handle to the procedure that writes it:
Dim expiredFile As Integer, expiringFile As Integer, notrainingFile As Integer
expiredFile = FreeFile
Open "R:\HR and Admin\Expired.txt" For Output As #expiredFile
expiringFile = FreeFile
Open "R:\HR and Admin\Expiring.txt" For Output As #expiringFile
notrainingFile = FreeFile
Open "R:\HR and Admin\NoTraining.txt" For Output As #notrainingFile
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(expiredFile, msg(1), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
personInquiryTraining.trainingExpiryDate)
End If
'...
Next
Close #expiredFile
Close #expiringFile
Close #notrainingFile
Called function example:
Private Function expired(FileNumber As Integer, ByRef msg As String, ByRef var1 As Variant, _
ByRef var2 As Variant, ByRef var3 As Variant) As String
expired = msg & "#var1 #var2 (#var3)#NL"
expired = Replace(expired, "#var1", var1)
expired = Replace(expired, "#var2", var2)
expired = Replace(expired, "#var3", var3)
Print #FileNumber, var1, var2, var3
End Function
Note that this is somewhat of a hack to fit your existing code, because you are doing too much in the calling procedure. A much better solution would be to separate the selection logic (your calling loop) from the file output entirely. It would be much more robust if you processed the array first, pushing the results into a Collection or some other container, and then had a single "write" function that takes a file name to generically write them to a passed file name.
I fixed your code. You missed Semicolon in your Print that why it didn't work.
Option Explicit
Private Function Expired( _
ByRef msg As String, _
ByRef var1 As Variant, _
ByRef var2 As Variant, _
ByRef var3 As Variant _
) As String
' Init Vars
Dim msg_ As String
Dim Block As String
Dim sFilePath As String: sFilePath = "R:\HR and Admin\Expired.txt"
Dim FileNumber As Integer: FileNumber = FreeFile
' Check if msg has no value
If msg = vbNullString Then msg_ = "Persons with EXPIRED Safeguading Certificates:#NL#NL"
Block = msg & _
"#" & var1 & " " & _
"#" & var2 & " " & _
"(#" & var3 & ")#NL"
' Text File
If Dir(sFilePath) = vbNullString Then
MsgBox "File Does not exists"
' Return nothing
Expired = vbNullString
Else
Open sFilePath For Output As #FileNumber
Print #FileNumber, var1, var2, var3;
Close #FileNumber
' Return Block
Expired = Block
End If
End Function
Private Sub CommandButton1_Click()
Debug.Print Expired("f", 1, 2, 3)
End Sub

VBA arrays/msg boxes etc

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
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
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

VBA worksheet_change limited to single column doesn't respond to automatic updates

I am building a patient database. I have code that checks for changes in a specific column. if data in that column reaches a certain range, i make it send an email. Currently when i manually update the column the program works flawlessly, but when i have a date based formula update it - the macro doesn't seem to recognize it.
What could the problem be?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 22 Then Exit Sub
Dim rng As Range
For Each rng In Range("V1:V14")
If (rng.Value < 5 And rng.Value > 1) Then
Call mymacro(rng.Address)
End If
Next rng
End Sub
Private Sub mymacro(theValue As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"The patient that is due is in cell: " & theValue
On Error Resume Next
With xOutMail
.To = "email#hotmail.com"
.CC = ""
.BCC = ""
.Subject = "Upcoming Patient"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
the formula that updates the column is
=IF(P7<>"",(P7-TODAY()),"")

Using an array to search active sheet

I have a worksheet which is updated regularly with details of duplicate records from a database.
I am trying to create a macro which searches for particular records however as I am new to Excel VBA I am struggling.
The code I currently have is as follows:
there are more names (21 to be precise but to save time I have removed these)
Dim rg As Range
Dim lnglastrow As Long
Dim intnamemax As Integer
Dim strName() As String
intnamemax = 21
ReDim strName(1 To intnamemax)
strName(1) = "Bob Smith"
strName(2) = "Rhys Jones"
strName(3) = "Rebecca Hickling"
lnglastrow = ActiveSheet.UsedRange.Rows.Count
For Each rg In Range("A2:A" & lnglastrow)
For i = 1 To intnamemax
Set c = rg.Find(strName(i), LookIn:=xlValues)
If Not c Is Nothing Then
MsgBox "Proxy Candidate Found at " & found.Address
Else
MsgBox "No Proxy Candidates Found ", vbOKOnly, "Success!"
End If
Next i
Next
End Sub
the Macro will run however when testing I get the msgbox no proxy candidates found despite there being an entry for one of the names.
I am struggling to figure out where I have gone wrong and would appreciate any help.
You need to pull the false return out of the loop, Or you will get at least 20 false even if one matches.
And you do not need the exterior loop as the FIND will look at the whole range as one.
Dim lnglastrow As Long
Dim intnamemax As Integer
Dim strName() As String
Dim fnd As Boolean
intnamemax = 21
ReDim strName(1 To intnamemax)
strName(1) = "Bob Smith"
strName(2) = "Rhys Jones"
strName(3) = "Rebecca Hickling"
lnglastrow = ActiveSheet.UsedRange.Rows.Count
For i = 1 To intnamemax
Set c = Range("A2:A" & lnglastrow).Find(strName(i), LookIn:=xlValues)
If Not c Is Nothing Then
MsgBox "Proxy Candidate Found at " & c.Address
fnd = True
Exit For
End If
Next i
If Not fnd Then
MsgBox "No Proxy Candidates Found ", vbOKOnly, "Success!"
End If
End Sub

Resources