VBA 数组写入 .txt 文件

Question

我在让我的数组正确写入 txt.file 时遇到问题。 它目前所做的是将结果显示在 msgbox 中，以便我们可以立即看到它，并且只将 msgbox 中出现的部分数据写入 txt.file。

我尝试使用显示所有数据的“附加”，但当然，它只是将数据添加到 txt.file，而不是替换已经存在的内容。 '输出'我认为是让它将所有数据写入txt.file的唯一方法，然后每次都替换它。

遗憾的是，我无法让它与“输出”一起使用。它目前只写入数组中的最后一行数据。

我认为我需要某种循环，但我无法找到让它成功工作的方法。

我的代码如下。任何帮助将不胜感激。

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

以下是vba表格的全部代码：

    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

您需要打开文件一次，而不是循环打开文件。更改现有代码的最简单方法是在开始循环之前打开所有 3 个文件，然后在完成后关闭它们。然后将打开的文件句柄传递给写入它的过程：

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

调用函数示例：

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

请注意，这有点适合您现有的代码，因为您在调用过程中做了太多事情。一个更好的解决方案是将选择逻辑（您的调用循环）与文件输出完全分开。如果您首先处理数组，将结果推送到Collection 或其他容器中，然后有一个“写入”函数，该函数接受一个文件名，通常将它们写入传递的文件名，那么它会更加健壮。

Answer 2

我修复了你的代码。您在Print 中错过了分号，这就是它不起作用的原因。

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