我怎样才能从数组中删除一个项目？

我有一个包含联系人电子邮件地址的Excel文件，如下所示。

ABC 1 Shop Supervisor Assistant 2 A [e-mail] [e-mail] 3 B [e-mail] 4 C [e-mail] [e-mail] 5 D 6 E [e-mail] [e-mail] 

我已经创build了一个用户表单，用户可以select他们想要发送电子邮件的angular色（主pipe或助理），或者如果需要，他们可以通过电子邮件发送电子邮件，然后有代码将这些angular色的电子邮件地址，打开一个新的电子邮件，电子邮件地址到“到”部分。 此代码如下所示：

  Private Sub btnEmail_Click() Dim To_Recipients As String Dim NoContacts() As String Dim objOutlook As Object Dim objMail As Object Dim firstRow As Long Dim lastRow As Long ReDim NoContacts(1 To 1) As String ' Define the column variables Dim Supervisor_Column As String, Assistant_Column As String Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) ' Add in the column references to where the email addresses are, eg Supervisor is in column K Supervisor_Column = "K" Assistant_Column = "M" ' Clear the To_Recipients string of any previous data To_Recipients = "" ' If the To Supervisor checkbox is ticked If chkToSupervisor.Value = True Then With ActiveSheet ' Get the first and last rows that can be seen with the filter firstRow = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Row lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' For every row between the first and last For Row = firstRow To lastRow ' Check if the row is visible - ie if it is included in the filter If Rows(Row).Hidden = False Then ' If it is visible then check to see whether there is data in the cell If Not IsEmpty(Range(Supervisor_Column & Row).Value) And Range(Supervisor_Column & Row).Value <> 0 Then ' If there is data then add it to the list of To_Recipients To_Recipients = To_Recipients & ";" & Range(Supervisor_Column & Row).Value Else ' See whether the shop is already in the array If UBound(Filter(NoContacts, Range("F" & Row).Value)) = -1 Then ' If it isn't then add it to the array NoContacts(UBound(NoContacts)) = Range("F" & Row).Value ReDim Preserve NoContacts(1 To UBound(NoContacts) + 1) As String End If End If End If ' Go onto the next row Next Row End With End If ' If the To Assistant checkbox is ticked If chkToAssistant.Value = True Then With ActiveSheet ' Get the first and last rows that can be seen with the filter firstRow = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Row lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' For every row between the first and last For Row = firstRow To lastRow ' Check if the row is visible - ie if it is included in the filter If Rows(Row).Hidden = False Then ' If it is visible then check to see whether there is data in the cell If Not IsEmpty(Range(Assistant_Column & Row).Value) And Range(Assistant_Column & Row).Value <> 0 Then ' If there is data then add it to the list of To_Recipients To_Recipients = To_Recipients & ";" & Range(Assistant_Column & Row).Value Else ' See whether the shop is already in the array If UBound(Filter(NoContacts, Range("F" & Row).Value)) = -1 Then ' If it isn't then add it to the array NoContacts(UBound(NoContacts)) = Range("F" & Row).Value ReDim Preserve NoContacts(1 To UBound(NoContacts) + 1) As String End If End If End If ' Go onto the next row Next Row End With End If With objMail .To = To_Recipients .Display End With Set objOutlook = Nothing Set objMail = Nothing ' Close the User Form Unload Me End Sub 

我想要做的是得到如果没有联系，例如在上面的例子中的商店“D”，出现一个消息框，说没有联系。 要做到这一点，我已经开始使用数组：

 NoContacts 

其中，从上面的代码可以看出：

 ' See whether the shop is already in the array If UBound(Filter(NoContacts, Range("F" & Row).Value)) = -1 Then ' If it isn't then add it to the array NoContacts(UBound(NoContacts)) = Range("F" & Row).Value ReDim Preserve NoContacts(1 To UBound(NoContacts) + 1) As String End if 

如果没有联系人，例如没有店铺“B”的主pipe，那么是否有店铺信件进入。 因为这段代码会查看所有的主pipe，也就是说，如果有一个电子邮件地址，并且在没有的情况下将商店添加到“NoContacts”数组，那么它会在B列中添加电子邮件地址到“To_Recipients”variables，然后继续给助理，我需要知道如何从数组中删除一个项目。

例如，上面的代码会将Shop“B”添加到数组中，因为它没有Supervisor，但是因为它有一个Assistant，所以在运行Assistant代码时需要从数组中删除Shop“B”，而Shop “D”将留在arrays，因为它没有主pipe或助理 – 请记住，我正在试图显示没有联系，所以没有包含在电子邮件中的商店列表。

这在我的脑海里是有道理的，但是如果我没有清楚地解释，请告诉我。

所以，为了澄清， 我怎样才能从数组中删除特定的项目？

Answer 1

您的代码可以简化为只循环一次，并同时检查pipe理员和助理：

 Private Sub btnEmail_Click() 'Add in the column references to where the email addresses are Const Supervisor_Column = "K" Const Assistant_Column = "M" Dim To_Recipients As String Dim NoContacts() As String Dim objOutlook As Object Dim objMail As Object Dim firstRow As Long, lastRow As Long Dim doSup As Boolean, doAssist As Boolean, eSup, eAssist Dim bHadContact As Boolean ReDim NoContacts(1 To 1) As String Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) doSup = chkToSupervisor.Value doAssist = chkToAssistant.Value To_Recipients = "" ' If either checkbox is ticked If doSup Or doAssist Then With ActiveSheet firstRow = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Row lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row For Row = firstRow To lastRow If Not Rows(Row).Hidden Then bHadContact = False eSup = Trim(.Cells(Row, Supervisor_Column)) eAssist = Trim(.Cells(Row, Assistant_Column)) If Len(eSup) > 0 And doSup Then To_Recipients = To_Recipients & ";" & eSup bHadContact = True End If If Len(eAssist) > 0 And doAssist Then To_Recipients = To_Recipients & ";" & eAssist bHadContact = True End If 'no assistant or supervisor - add the shop If Not bHadContact Then NoContacts(UBound(NoContacts)) = .Cells(Row, "F").Value ReDim Preserve NoContacts(1 To UBound(NoContacts) + 1) End If End If 'not hidden Next Row End With End If With objMail .To = To_Recipients .Display End With If UBound(NoContacts) > 1 Then MsgBox "One or more stores had no contacts:" & vbCrLf & Join(NoContacts, vbLf), _ vbExclamation End If Set objOutlook = Nothing Set objMail = Nothing ' Close the User Form Unload Me End Sub 

要回答你的具体问题，没有内置的方法来从数组中删除一个或多个项目。 你可以构build一个函数或子类来完成这个工作：遍历数组并将其项目复制到第二个数组中，不包括要删除的项目。

例：

 Sub Tester() Dim arr arr = Split("A,B,C,D", ",") Debug.Print "Before:", Join(arr, ",") RemoveItem arr, "A" Debug.Print "After:", Join(arr, ",") End Sub Sub RemoveItem(ByRef arr, v) Dim rv(), i As Long, n As Long, ub As Long, lb As Long lb = LBound(arr): ub = UBound(arr) ReDim rv(lb To ub) For i = lb To ub If arr(i) <> v Then rv(i - n) = arr(i) Else n = n + 1 End If Next 'check bounds before resizing If (ub - n) >= lb Then ReDim Preserve rv(lb To ub - n) arr = rv End Sub