Remove duplicates if team email address in the recipients - vba

Question

We have a team email address that we CC for most correspondence, and then we all get a copy of all emails.
The problem is when we then reply all, and a team member has already been in the email chain that person will get the email 2 times.
This is what I tried.
Private Sub RemoveRecipientsWhenItemSend(Item As Outlook.MailItem)
Dim RemoveAddrList As VBA.Collection
Dim InfoAddrList As VBA.Collection
Dim Recipients As Outlook.Recipients
Dim aRecipient As Outlook.Recipient
Dim bRecipient As Outlook.Recipient
Dim i
Dim j
Dim a
Dim b
Dim info As Boolean
info = False
Set RemoveAddrList = New VBA.Collection
Set InfoAddrList = New VBA.Collection
InfoAddrList.Add "team#company.com"
RemoveAddrList.Add "member1#company.com"
RemoveAddrList.Add "member2#company.com"
Set Recipients = Item.Recipients
For i = Recipients.Count To 1 Step -1
Set aRecipient = Recipients.Item(i)
For j = 1 To InfoAddrList.Count
If LCase$(aRecipient.Address) = LCase$(InfoAddrList(j)) Then
For a = Recipients.Count To 1 Step -1
Set bRecipient = Recipients.Item(a)
For b = 1 To RemoveAddrList.Count
If LCase$(aRecipient.Address) = LCase$(RemoveAddrList(b)) Then
Recipients.Remove i
Exit For
End If
Next
Next
Exit For
End If
Next
Next
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
RemoveRecipientsWhenItemSend Item
End Sub

Answer 1

A few Debug.Print statements proved helpful.
Option Explicit
Private Sub RemoveRecipientsWhenItemSend(Item As Outlook.mailitem)
Dim RemoveAddrList As VBA.Collection
Dim InfoAddrList As VBA.Collection
Dim Recipients As Outlook.Recipients
Dim aRecipient As Outlook.Recipient
Dim bRecipient As Outlook.Recipient
Dim i
Dim j
Dim a
Dim b
Dim info As Boolean
info = False
Set RemoveAddrList = New VBA.Collection
Set InfoAddrList = New VBA.Collection
InfoAddrList.Add "team#company.com"
RemoveAddrList.Add "member1#company.com"
RemoveAddrList.Add "member2#company.com"
Set Recipients = Item.Recipients
For i = Recipients.count To 1 Step -1
Set aRecipient = Recipients.Item(i)
For j = 1 To InfoAddrList.count
Debug.Print LCase$(aRecipient.Address)
Debug.Print LCase$(InfoAddrList(j))
If LCase$(aRecipient.Address) = LCase$(InfoAddrList(j)) Then
For a = Recipients.count To 1 Step -1
'Set bRecipient = Recipients.Item(a)
Set aRecipient = Recipients.Item(a)
For b = 1 To RemoveAddrList.count
Debug.Print vbCr & " a: " & a
Debug.Print " LCase$(aRecipient.Address): " & LCase$(aRecipient.Address)
Debug.Print " LCase$(RemoveAddrList(b)): " & LCase$(RemoveAddrList(b))
If LCase$(aRecipient.Address) = LCase$(RemoveAddrList(b)) Then
'Recipients.Remove i
Recipients.Remove a
Exit For
End If
Next
Next
Exit For
End If
Next
Next
End Sub
Private Sub RemoveRecipientsWhenItemSend_test()
RemoveRecipientsWhenItemSend ActiveInspector.currentItem
End Sub

Answer 2

Here is something I use to remove the duplicate recipients.
Set olemail = olapp.CreateItemFromTemplate(OutlookTemplate)
With olemail
' other stuff
' check duplicate recipients
' first resolve email address per global address book
For Each Recipient In .Recipients
Recipient.Resolve
Next
' go through each recipients and check for dup
If .Recipients.count > 1 Then
For i = .Recipients.count To 2 Step -1
For j = i - 1 To 1 Step -1
If .Recipients(i) = .Recipients(j) Then
.Recipients.Remove (i)
i = i - 1
End If
Next j
Next i
End If
end with