2016-02-22 4 views
0

У меня есть файл Excel, содержащий контактные адреса электронной почты, например, ниже.Как удалить элемент из массива?

 A  B      C 
1  Shop  Supervisor   Assistant 
2  A  [email protected] [email protected] 
3  B        [email protected] 
4  C  [email protected]  [email protected] 
5  D   
6  E  [email protected] [email protected] 

Я создал UserForm, где пользователь может выбрать, какую роль они хотят по электронной почте (руководитель или помощник), или они могут по электронной почте и в случае необходимости, а затем есть код, который принимает адреса электронной почты для этих ролей, открывает новое письмо и добавляет адреса электронной почты в раздел «Кому». Этот код выглядит следующим образом:

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». Поскольку этот код просматривается во всех Supervisors, то есть он запускает столбец B, добавляя адреса электронной почты к переменной «To_Recipients», если есть адрес электронной почты и добавление магазина в массив «NoContacts», если этого не происходит, затем продолжается Помощникам, мне нужно знать, как удалить элемент из массива.

Например, приведенный выше код добавит магазин «B» в массив, поскольку он не имеет диспетчера, однако, поскольку он имеет помощника, мне нужно удалить Shop «B» из массива, когда он запускает помощник кода, тогда как магазин «D» останется в массиве, потому что у него нет ни супервизора, ни помощника. Помните, что я пытаюсь отобразить список магазинов, у которых нет контакта, и поэтому они не включены в электронную почту.

Это имеет смысл в моем сознании, однако, пожалуйста, дайте мне знать, если я не объясню это четко.

Так, чтобы уточнить, как я могу удалить определенный элемент из массива?

не
+0

http://stackoverflow.com/questions/7000334/deleting-elements-in-an-array-if-element-is-a-certain-value-vba – MatthewD

+0

Спасибо для обеспечения этого я уже рассмотрел этот вопрос, хотя у меня нет сильного понимания массивов, поэтому я надеялся на немного больше указаний и объяснений. –

+0

Вы можете использовать коллекцию vba вместо массива. Коллекция намного удобнее, чем массив. Удалить элемент из коллекции так же просто, как вызвать метод Remove (...). Но заметьте [это] (http://stackoverflow.com/questions/10579457/why-use-arrays-in-vba-when-there-are-collections?rq=1). – dee

ответ

3

Ваш код может быть упрощена только зацикливание по рядам один раз, и проверки как руководителя и помощника в то же время:

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 
+0

Привет, Тим, благодарю вас за предоставление этого и вашего совета, однако пример, который я привел в верхней части, упрощен, так как существует довольно много разных ролей, которые пользователь мог бы отправить по электронной почте. Не могли бы вы помочь мне скопировать элементы массива в массив разделов, кроме элементов, которые нужно удалить? –

+0

Смотрите мое обновление выше. –

Смежные вопросы