Arrays VBA阵列/消息框等
我需要一个msgbox出现，如果没有过期，正在过期，只要有数据在1，2和19。目前，它为符合上述条件的任何人显示，但只有当每一行符合上述条件时，它才会出现。然后，它应该拒绝出现其他MSGBox 请参阅下面的所有代码Arrays VBA阵列/消息框等,arrays,vba,excel,msgbox,Arrays,Vba,Excel,Msgbox,我需要一个msgbox出现，如果没有过期，正在过期，只要有数据在1，2和19。目前，它为符合上述条件的任何人显示，但只有当每一行符合上述条件时，它才会出现。然后，它应该拒绝出现其他MSGBox 请参阅下面的所有代码 Sub Expire_New() Dim arr() As Variant Dim msg(1 To 4) As String Dim x As Long Dim dDiff As Long Wi
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
因此，我对msg4的实际需求是，我只希望在msg1、msg2和msg3的标准不匹配的情况下才会出现这种情况。如果出现msg4，则其他3个msg不应出现。msg1查找列出的日期早于当前日期的任何行/单元格。msg2查找当前日期在列出日期后31天内的行/单元格。msg3查找没有列出日期但在第1列或第2列中有名称的行/单元格。因此，如果第19列单元格中列出的日期超过31天，并且在1和2中有一个名称，那么msg4应该出现，而不是1、2或3。1和2包含名称，19包含日期
代码在这里的第3页：查看您的决策声明后，问题在于您的逻辑。在下面的代码中，我清理了逻辑。内联注释解释了所做的操作。在更详细地查看工作簿之后，您将混合使用本应生成报表的数据库应用程序和试图将其视为数据库的报表。人们总是这样做。大多数人在Excel中编写报告，然后尝试进行分析或数据库操作
您应该考虑对所有表进行标准化，使用Excel对象表为ListObjor。 我还使用了Microsoft的脚本字典加载项。必须将其添加到工作簿引用中。在VBE中，单击“工具”菜单项，然后单击“参照”。工具->参考。对话框出现后，向下滚动，直到找到Microsoft脚本运行时。单击复选框，然后单击确定
您还需要更改工作表上的代码。您可以删除那里的所有内容并将其替换为 'In this case use of the ActiveSheet
'is ok since the button pressed
'is on the ActiveSheet
Expire_New ActiveSheet, "First Name"
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
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
问题描述没有您想象的那么清楚。请阅读。您是否尝试过设置断点F9，单步执行代码F8，并在“局部变量”工具窗口中检查值，以查看出错的地方？我认为主要是由于代码的位置，可能这一位的编码也是错误的。我认为，由于代码的位置，它是作为数组的一部分来执行此操作的，因此对于与IF语句匹配的任何行/单元格都会执行此操作。我需要它只在每一行都符合上面的要求，而不是阵列中的任何msg1、msg2或msg3部分的情况下执行，因此它不应该继续处理msg1、msg2或msg3。这是更好的解释吗？首先，msg4=MsgBox。。。意味着您正在将MsgBox调用的结果存储到msg数组的下标4中，该结果将是VbMsgBoxResult.vbOk的整数表示形式，…这很可能是无用的，完全不是您想要的，我不知道该代码应该做什么，也不知道您试图做什么。你需要把范围缩小到一个更具体的问题上。因此，我对msg4的实际要求是，我只希望在msg1、msg2和msg3的标准不匹配的情况下，才提出这个问题。如果出现msg4，则其他3个msg不应出现。msg1查找列出的日期早于当前日期的任何行/单元格。msg2查找当前日期在列出日期后31天内的行/单元格。msg3查找没有列出日期但在第1列或第2列中有名称的行/单元格。因此，如果第19列单元格中列出的日期超过31天，并且第1和第2列中有一个名称，那么msg4应该出现，而不是第1、2或3列。您可以并且应该使用问题下方的链接添加相关信息并删除无用的部分。从注释中挑选重要信息是非常困难的。常量Public Const NAME_COL的声明Long=1必须放在模块、类或表单代码的顶部。它们不能包含在子定义或函数定义中。否则您将看到编译器错误。是的，请保留您的私有函数。他们工作得很好，所以我只提供了我更改或添加的代码。它似乎工作得很好。有几件事可能需要分类。Case Else的培训缺少msg3=NoTrainingmsg3，arrx，NAME_COL，arrx，2，uarrx，18此时，最好使用VB编辑器的V遍历代码 做调试器。如果您不熟悉使用调试器，这是VBA函数和VBE的重要参考。看一看。另外一个你应该注册的网站是。他的搜索功能不起作用，但他有大量可用的示例代码。如果if NoExpiredTraining语句的计算结果为True，则只会显示一条消息-显示没有即将进行或缺少的培训。代码执行Else子句的唯一方式是培训过期、过期或丢失。查看一下您的数据源，您可能会发现其中一种情况。
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
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