Premenná obsahuje rovnaké hodnoty (VBA) - excel, vba, excel-vba, if-statement

Pri generovaní mailing listu som si uvedomil, že vo svojej premennej „To“ obsahuje rovnaké hodnoty test@test.com, Zoznam adries bol definovaný v jazyku Visual Basicpre aplikácie (VBA). No, uvažujem o tom, ako by som mohol definovať príkaz na kontrolu, keď má premenná rovnaké hodnoty, potom orezať všetky duplikáty. To znamená, že potrebujem, aby sa premenná objavila iba raz v zozname adries.

Napríklad:

Dim objMail As Object
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

With objMail
.To = test@test.com; name1@test.com; name2@test.com; name3@test.com; test@test.com; name4@test.com
...
End With

Má niekto nápad?

odpovede:

Na odstránenie duplikátov môžete použiť slovník:

Sub Test()

Dim EmailAddresses As String

EmailAddresses = "test@test.com; name1@test.com; name2@test.com; name3@test.com; test@test.com; name4@test.com"
EmailAddresses = RemoveDuplicates(EmailAddresses)

Debug.Print EmailAddresses

End Sub

Public Function RemoveDuplicates(sTo As String) As String

Dim dict As Object
Dim vEmails As Variant
Dim x As Long
Dim sTemp As String

vEmails = Split(Replace(sTo, " ", ""), ";")
If UBound(vEmails) > 0 Then
"Remove duplicates.
Set dict = CreateObject("Scripting.Dictionary")
For x = LBound(vEmails) To UBound(vEmails)
If Not dict.exists(vEmails(x)) Then
dict.Add vEmails(x), 1
sTemp = sTemp & vEmails(x) & ";"
End If
Next x
sTemp = Left(sTemp, Len(sTemp) - 1) "Remove the final ;
RemoveDuplicates = sTemp
Else
"There"s only 1 address.
RemoveDuplicates = sTo
End If

End Function

Vyššie uvedené možno skutočne zjednodušiť niekoľkými spôsobmi, ak je to vaša preferencia.

1. Pre takéto jednoduché odblokovanie nie je potrebné používať.Exists metóda alebo metóda .Add metóda, pretože položky slovníka sa vytvárajú lenivo. To znamená, že jednoduché referencovanie položky ju vytvorí, ak neexistuje, alebo ju prepíše, ak existuje.
2. Namiesto manuálneho vytvárania reťazca paralelne so slovníkom môžete Join fungovať podľa diktátu Keys.

Tu je revidovaná verzia:

Public Function RemoveDuplicates2(sTo As String) As String
Dim dict As Object
Dim vEmails As Variant
Dim x As Long

vEmails = Split(Replace(sTo, " ", ""), ";")
Set dict = CreateObject("Scripting.Dictionary")
For x = LBound(vEmails) To UBound(vEmails)
dict(vEmails(x)) = dict(vEmails(x)) "Keep track of how many occurrences, in case you want to do something with it later
Next

RemoveDuplicates = Join(dict.Keys(), "; ")

End Function