Comment supprimer les valeurs en double de deux colonnes dans Excel à l'aide de VBA ?

Question

Je suis novice en matière de programmation Excel VBA. J'ai une feuille Excel avec deux colonnes, et chaque colonne contient des adresses électroniques séparées par @@.
ColumA
aa@yahoo.com@@bb@yahoo.com@@cc@yahoo.com
x@.com@@y@y.com

ColonneB
zz@yahoo.com@@aa@yahoo.com
aa@yahoo.com

Comme vous pouvez le voir, les deux colonnes ont deux lignes, j'ai besoin d'une troisième colonne qui contiendrait toutes les valeurs uniques.
ColonneC
aa@yahoo.com@@bb@yahoo.com@@cc@yahoo.com@zz@yahoo.com
x@.com@@y@y.com@@aa@yahoo.com

Merci

Answer 1

Quelque chose comme ceci avec des tableaux de variantes et un dictionnaire est un processus efficace pour obtenir le résultat souhaité.

[ actualisé pour supprimer le délimiteur au début de la chaîne, le code est flexible sur la longueur du délimiteur]. SO semble avoir supprimé la possibilité de télécharger des images et ma photo a disparu ....

Sub GetUniques()
Dim strDelim As String
Dim X
Dim Y
Dim objDic As Object
Dim lngRow As Long
Dim lngRow2 As Long
strDelim = "@@"
Set objDic = CreateObject("scripting.dictionary")
X = Range([a1], Cells(Rows.Count, "B").End(xlUp)).Value2
For lngRow = 1 To UBound(X, 1)
    X(lngRow, 1) = X(lngRow, 1) & strDelim & X(lngRow, 2)
    Y = Split(X(lngRow, 1), strDelim)
    X(lngRow, 1) = vbNullString
    For lngRow2 = 0 To UBound(Y, 1)
        If Not objDic.exists(lngRow & Y(lngRow2)) Then
            X(lngRow, 1) = X(lngRow, 1) & (strDelim & Y(lngRow2))
            objDic.Add (lngRow & Y(lngRow2)), 1
        End If
    Next lngRow2
    If Len(X(lngRow, 1)) > Len(strDelim) Then X(lngRow, 1) = Right(X(lngRow, 1), Len(X(lngRow, 1)) - Len(strDelim))
Next lngRow
[c1].Resize(UBound(X, 1), 1).Value2 = X
End Sub

Answer 2

Voici mon point de vue. Comment ça marche :

1. Déposer les colonnes A et B dans un tableau de variantes.
2. Combinez chaque ligne, divisez-la en un tableau d'emails, puis éliminez les doublons avec un dictionnaire.
3. Combinez une liste unique en une seule chaîne de caractères et stockez-la dans un nouveau tableau.

4. Transposez le nouveau tableau sur la colonne C.

   Sub JoinAndUnique()

   Application.ScreenUpdating = False Dim varray As Variant, newArray As Variant Dim i As Long, lastRow As Long Dim temp As Variant, email As Variant Dim newString As String, seperator As String Dim dict As Object Set dict = CreateObject("scripting.dictionary")

   seperator = "@@" lastRow = range("A" & Rows.count).End(xlUp).Row varray = range("A1:B" & lastRow).Value ReDim newArray(1 To UBound(varray, 1))

   On Error Resume Next For i = 1 To UBound(varray, 1) temp = Split(varray(i, 1) & seperator & varray(i, 2), seperator) For Each email In temp If Not dict.exists(email) Then dict.Add email, 1 newString = newString & (seperator & email) End If Next newArray(i) = Mid$(newString, 3) dict.RemoveAll newString = vbNullString Next

   range("C1").Resize(UBound(newArray)).Value = Application.Transpose(newArray) Application.ScreenUpdating = True

   End Sub

Note : C'est assez similaire à la réponse de brettdj, mais il y a quelques différences qui méritent d'être mentionnées :

• J'ai utilisé des noms plus significatifs pour les variables (pour la lisibilité et pour faciliter l'édition).
• Je nettoie les "@@" en début de phrase.
• J'utilise un nouveau tableau plutôt que d'écraser les valeurs d'un tableau existant.
• Je choisis d'effacer le dictionnaire après chaque cellule
• Je choisis d'utiliser "on error resume next" et de verser les entrées dans le dictionnaire au lieu de vérifier si elles existent ou non (préférence personnelle, ne fait pas de différence majeure).

Answer 3

Le moyen le plus simple d'y parvenir est d'utiliser la fonction objet du dictionnaire , fonction de fractionnement y fonction de liaison . Bien sûr, vous n'êtes pas obligé d'utiliser ces mêmes mots, mais faites un essai et voyez ce que vous obtenez.