VBA array write to .txt file - arrays

Question

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

Answer 1

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.

Answer 2

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