如何从数组中删除项目？

Question

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

      A        B                     C
1     Shop     Supervisor            Assistant
2     A        hulk.hogan@web.com    freddie.mercury@web.com
3     B                              brian.may@web.com
4     C        triple.h@web.com      roger.taylor@web.com
5     D        
6     E        randy.orton@web.com   john.deacom@web.com

我创建了一个用户表单，用户可以在其中选择他们想要发送电子邮件的角色（主管或助理），或者如果需要，他们可以同时发送电子邮件，然后有代码获取这些角色的电子邮件地址，打开一封新电子邮件，并添加电子邮件地址放入“收件人”部分。这段代码如下：

 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, e.g. 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 - i.e. 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 - i.e. 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”这样的主管，是否将商店信函输入其中。因为此代码查看所有主管，即它沿着 B 列运行，如果有电子邮件地址，则将电子邮件地址添加到“To_Recipients”变量，如果没有，则将商店添加到“NoContacts”数组，然后继续对于助理，我需要知道如何从数组中删除项目。

例如，上面的代码会将商店“B”添加到数组中，因为它没有主管，但是因为它有助理，所以我需要在运行助理代码时从数组中删除商店“B”，而商店“D”将保留在数组中，因为它既没有主管也没有助理 - 请记住，我正在尝试显示没有联系方式的商店列表，因此未包含在电子邮件中。

这在我看来是有道理的，但是如果我没有解释清楚，请告诉我。

那么，澄清一下，如何从数组中删除特定项目？

Answer 1

您的代码可以通过仅循环一次行并同时检查主管和助理来简化：

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

不过，为了回答您的具体问题，没有内置方法可以从数组中删除一项或多项。您可以构建一个函数或子函数来执行此操作：循环遍历数组并将其项目复制到第二个数组，不包括要删除的项目。

例子：

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