VBA 数组/消息框等答案

【问题标题】：VBA arrays/msg boxes etcVBA 数组/消息框等
【发布时间】：2018-09-24 14:17:54
【问题描述】：

如果没有任何内容已过期、即将过期并且只要 1、2 和 19 中有数据，我需要显示一个 msgbox。目前它会为符合上述条件的任何人显示它，但只有在每个单行符合上述要求。然后它应该拒绝其他 msgboxes 出现。

请查看下面的所有代码。

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

我认为这是导致问题的以下部分。我不认为这应该在主数组中？

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

所以我实际上想要的“msg(4)”是我希望只有在 msg(1)、msg(2) 和 msg(3) 的标准不匹配时才会出现。如果 msg(4) 出现，那么其他 3 个 msg 不应该出现。 msg1 查找列出的日期早于当前日期的任何行/单元格。 msg2 查找当前日期在所列日期的 31 天内的行/单元格。 msg3 查找没有列出日期但在第 1 列或第 2 列中有名称的行/单元格。因此，如果列出的日期（在第 19 列的单元格中）超过 31 天，并且在 1 中有名称和 2，那么 msg4 应该出现，而不是 1、2 或 3。1 和 2 包含名称，19 包含日期。

代码在此处的第 3 页上：https://www.dropbox.com/s/9m1hx2tylv1k470/SCR%20as%20of%2017%2009%2018%20-%20Copy%20-%20Copy.xlsm?dl=0

【问题讨论】：

问题描述并不像您想象的那么清晰。请阅读minimal reproducible example。您是否尝试过设置断点 (F9) 并单步执行代码 (F8) 并检查 locals 工具窗口中的值以查看哪里出错了？
我认为这主要取决于代码的位置（也许这个位的编码也是错误的。我认为由于代码的位置，它是作为数组的一部分这样做的对与 IF 语句匹配的任何行/单元格也是如此。我需要它只在每一行都符合上述条件时才这样做（而不是 msg(1)、msg(2) 或 msg(3 中的任何一个) ) 部分），因此它不应该继续使用 msg(1)、msg(2) 或 msg(3)。这是更好的解释吗？
一方面，msg(4) = MsgBox(...) 表示您将 MsgBox 调用的结果存储到 msg 数组的下标 4 中，该结果将是 @987654329 的整数表示@, ...这很可能是无用的，而且根本不是你想要的，而且我不知道该代码应该做什么，也不知道你想要做什么。您需要缩小范围以解决更具体的问题。
所以我实际上想要的“msg(4)”是我希望只有当 msg(1)、msg(2) 和 msg(3) 的标准不满足时才会出现匹配。如果 msg(4) 出现，那么其他 3 个 msg 不应该出现。 msg1 查找列出的日期早于当前日期的任何行/单元格。 msg2 查找当前日期在所列日期的 31 天内的行/单元格。 msg3 查找没有列出日期但在第 1 列或第 2 列中有名称的行/单元格。因此，如果列出的日期（在第 19 列的单元格中）超过 31 天，并且在 1 中有名称和 2，那么 msg4 应该出现而不是 1、2 或 3。
您可以（并且应该）使用问题下方的edit 链接添加相关信息并删除无用的部分。从 cmets 中提取重要信息非常困难。

标签： arrays vba excel msgbox

【解决方案1】：

Public Sub Expire_New(ByRef ws As Worksheet, ByVal Name As String)

Dim msg(1 To 3) As String
Dim x           As Long
Dim nDx         As Long
Dim dDiff       As Long

'Establish the location of the first cell (range) of the Safegaurding Training block
'Find the first instance of Safeguarding Training on the sheet
Dim sgTrainingCol As Range
With ws.Range("A1:AA1000")  'Using something large to provide a range to search
    Set sgTrainingCol = .Find("Safeguarding Training", LookIn:=xlValues)
End With

'Establish the location of the first cell (range) of the heading column
'for the table on the sheet. Find the first instance of what is contained
'in mTitleFirstHeadingColumn
Dim HeadingRangeStart As Range
With ws.Range("A1:AA1000")  'Using something large to provide a range to search
    Set HeadingRangeStart = .Find(Name, LookIn:=xlValues)
End With

Dim TrainingInfoRange As Range
Dim personFNSR As Range
With ws
    'finds the last row of the Heading column that has data, there can NOT be any empty rows
    'in the middle of this search.  It assumes that the name column date is contigous until
    'reaching the end of the data set.
    x = .Cells(HeadingRangeStart.Row, HeadingRangeStart.Column).End(xlDown).Row
    'Set the TrainingInfoRange to point to the data contained in the 4 columns under Safeguarding Training
    Set TrainingInfoRange = .Range(.Cells(sgTrainingCol.Row + 2, sgTrainingCol.Column), .Cells(x, sgTrainingCol.Column + 3))
    'Set pseronFNSR to the First Name/Name, Surname range
    Set personFNSR = .Range(.Cells(HeadingRangeStart.Row + 1, HeadingRangeStart.Column), .Cells(x, HeadingRangeStart.Column + 1))
End With

'I am a big fan of collections and scripting dictionaries.
'They make code easier to read and to implement.
Dim trainingDate As Scripting.Dictionary
Set trainingDate = CopyRngDimToCollection(personFNSR, TrainingInfoRange)

'This boolean will be used to control continued flow of the
'macro.  If NoExpiredTraining gets set to false, then there
'are people who must complete training.
Dim NoExpiredTraining As Boolean: NoExpiredTraining = True

'person training inquiry object - see class definition
Dim personInquiryTraining As clPersonTraining

'this is an index variable used to loop through items
'contained in the Scripting Dictionary object
Dim Key As Variant

For Each Key In trainingDate.Keys
    'Assing the next object in the trainingDate Scripting Dictionary
    'to the person training inquiry object
    Set personInquiryTraining = trainingDate(Key)
    'Check to see if there are any training issues
    'if so, then set NoExpiredTraining to False
    'because there is expired, expiring or missing training
    If personInquiryTraining.ExpiringTraining _
      Or personInquiryTraining.NoTraining _
      Or personInquiryTraining.TrainingExpired Then
        NoExpiredTraining = False
    End If
Next

If NoExpiredTraining Then
    'msg(4) = MsgBox("There are either no ...
    'is only used if want to do something based on
    'what button the user pressed.  Otherwise use
    'the Method form of MsgBox
    MsgBox "There are either no expired safeguarding certificates, " _
         & "or no certificate expiring within the next 31 days.", _
         vbCritical, "Warning"
    Exit Sub
End If

'If this code executes, then there is expired training.
'Let's collect the status for each individual
For Each Key In trainingDate.Keys
    Set personInquiryTraining = trainingDate(Key)
    If personInquiryTraining.TrainingExpired _
      And personInquiryTraining.trainingDate <> DateSerial(1900, 1, 1) Then 'Training 
is expired
        msg(1) = Expired(msg(1), _
              personInquiryTraining.firstName, _
              personInquiryTraining.surName, _
              personInquiryTraining.trainingExpiryDate)
    End If
    If personInquiryTraining.ExpiringTraining _
      And personInquiryTraining.trainingExpiryDate <> DateSerial(1900, 1, 1) Then 
'Training is expiring
        msg(2) = Expiring(msg(2), _
              personInquiryTraining.firstName, _
              personInquiryTraining.surName, _
              personInquiryTraining.trainingExpiryDate, _
              DateDiff("d", Date, personInquiryTraining.trainingExpiryDate))
    End If
    If personInquiryTraining.NoTraining Then 'Training is None
        msg(3) = NoTraining(msg(3), _
              personInquiryTraining.firstName, _
              personInquiryTraining.surName, _
              "NONE")
    End If
Next

'Because of the Exit Sub statement above, the code bwlow
'will only execute if there are expired, expiring or missing
'training
For x = LBound(msg) To UBound(msg)
    msg(x) = Replace(msg(x), "@NL", vbCrLf)
    If Len(msg(x)) < 1024 Then
    Select Case msg(x)
Case msg(1)
    If Len(msg(x)) & vbNullString > 0 Then
        'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf 
& msg(x), vbExclamation, "Safeguarding Certificate Notification"
        MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
        End If
Case msg(2)
    If Len(msg(x)) & vbNullString > 0 Then
        'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf 
& msg(x), vbExclamation, "Safeguarding Certificate Notification"
        MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
        End If
Case msg(3)
    If Len(msg(x)) & vbNullString > 0 Then
        'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf 
& msg(x), vbExclamation, "Safeguarding Certificate Notification"
        MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
        End If
        End Select
Else
     MsgBox "String length for notification too long to fit into this MessageBox", 
vbExclamation, "Invalid String Length to Display"
End If

Next x

End Sub

'***************************************************************************
'**
'** This fucntion copies all rows of data for the column specified into
'** a scripting dictionary
Private Function CopyRngDimToCollection(ByRef mFNSR As Range, ByRef mTrainInfo) As 
Scripting.Dictionary

Dim retVal As New Scripting.Dictionary
'nDx will become a key for each of the scripting dictionary items
Dim nDx As Long: nDx = 1
'person training inquiry object - see class definition
Dim personTraining As clPersonTraining

Dim mRow As Range
For Each mRow In mFNSR.Rows
    'instantiate a new person training inquiry object
    Set personTraining = New clPersonTraining
    With personTraining
        .firstName = mRow.Value2(1, 1)
        .surName = mRow.Value2(1, 2)
    End With
    retVal.Add nDx, personTraining
    nDx = nDx + 1
Next
nDx = 1

For Each mRow In mTrainInfo.Rows
    'Retrieve the person training inquiry object
    'from the scripting dictionary (retVal)
    Set personTraining = retVal(nDx)

    'Add the training data information to
    'the person training inquiry object
    With personTraining
        'Next two equations determine if the excel range has a null value
        'if so then the person training inquiry object's date field is set to a
        'default value of 1-1-1900 - this could be any valid date
        'otherwise the value is set to what is in the excel range from the sheet
        .trainingDate = IIf(mRow.Value2(1, 1) = vbNullString, DateSerial(1900, 1, 1), 
mRow.Value2(1, 1))
        .trainingExpiryDate = IIf(mRow.Value2(1, 2) = vbNullString, DateSerial(1900, 
1, 1), mRow.Value2(1, 2))
        .trainingLevel = mRow.Value2(1, 3)
        .certSeenBy = mRow.Value2(1, 4)
    End With
    'Update the object stored at the current key location
    'given by the value of nDx
    Set retVal(nDx) = personTraining
    nDx = nDx + 1
Next

'Set the return value for the function
Set CopyRngDimToCollection = retVal

End Function

Private Function Expired(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As 
Variant, ByRef var3 As Variant) As String

If Len(msg) = 0 Then msg = "Persons with EXPIRED Safeguading Certificates:@NL@NL"
Expired = msg & "@var1 @var2 (@var3)@NL"
Expired = Replace(Expired, "@var1", var1)
Expired = Replace(Expired, "@var2", var2)
Expired = Replace(Expired, "@var3", var3)

End Function

Private Function Expiring(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As 
Variant, ByRef var3 As Variant, ByRef d As Long) As String

If Len(msg) = 0 Then msg = "Persons with EXPIRING Safeguarding Certificates:@NL@NL"

Expiring = msg & "@var1 @var2 (@var3) (@d days remaining)@NL"
Expiring = Replace(Expiring, "@var1", var1)
Expiring = Replace(Expiring, "@var2", var2)
Expiring = Replace(Expiring, "@var3", var3)
Expiring = Replace(Expiring, "@d", d)


End Function

Private Function NoTraining(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As 
Variant, ByRef var3 As Variant) As String

If Len(msg) = 0 Then msg = "SAFEGUARDING TRAINING NOT COMPLETED FOR: @NL@NL"

NoTraining = msg & " @var1 @var2@NL"
NoTraining = Replace(NoTraining, "@var1", var1)
NoTraining = Replace(NoTraining, "@var2", var2)
NoTraining = Replace(NoTraining, "@var3", var3)

End Function

和

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

【讨论】：

【解决方案2】：

查看您的决策陈述后，问题出在您的逻辑上。在下面的代码中，我清理了逻辑。内联 cmets 解释了做了什么。在更详细地查看您的工作簿之后，您将应该是生成报告的数据库应用程序与您尝试将其视为数据库的报告混合在一起。人们一直这样做。大多数人使用 Excel 编写报告，然后尝试进行分析或数据库操作。

您应该考虑将所有表格标准化并使用属于 ListObjects 的 Excel 表格。

我还使用了 Microsoft 的 Scripting Dictionary 插件。您必须将此添加到您的工作簿引用中。在 VBE 中单击工具菜单项，然后单击参考。 (Tools->Reference)。出现对话框后，向下滚动，直到找到 Microsoft Scripting Runtimes。单击复选框，然后单击确定。

您还需要更改工作表上的代码。您可以删除那里的所有内容并将其替换为

    'In this case use of the ActiveSheet
    'is ok since the button pressed
    'is on the ActiveSheet
    Expire_New ActiveSheet, "First Name"

注意，Expire_New 子例程的第二个参数，必须反映您在每张纸上为 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

您还需要在工作簿中添加一个班级。在 VB 编辑器窗口中，单击 Insert->Class Module。添加后，将类的名称更改为clPersonTraining。并将以下代码粘贴到该类中：

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

这是一个提供答案的非常简单的类。有关 VBA 类的更多信息，我建议您购买一本有关 VBA 编程语言的书。它将比这里更详细地涵盖该主题

【讨论】：

常量Public Const NAME_COL as Long = 1 的声明必须放在模块、类或表单代码的顶部。它们不能包含在 Sub 或 Function 定义中。否则你会得到你所看到的编译器错误。
是的，请保留您的私人功能。他们工作得很好，所以我只提供了我更改或添加的代码。
它似乎运作良好。只有几件事可能需要排序。 Case Else '缺少训练 msg(3) = NoTraining(msg(3), _ arr(x, NAME_COL), _ arr(x, 2), _ arr(x, 18))
此时，最好的办法是使用 VB 编辑器 (VBE) 调试器“遍历”您的代码。如果您不熟悉使用调试器，Tech on the Net 是 VBA 函数和 VBE 的一个很好的参考。看看MS Excel 2016: VBA Debugging Introduction。另一个你应该收藏的网站是Chip Pearson's blog。他的搜索功能不起作用，但他有大量的示例代码可用。
如果声明 If NoExpiredTraining Then 计算结果为 True，则只会出现一条消息 - 显示没有即将进行或缺少的培训。代码执行Else 子句的唯一方式是训练过期、过期或丢失。查看您的数据源，您可能会发现其中一种情况。