Как удалить дубликаты значений из 2 столбцов в Excel с помощью VBA

Question

Я новичок в программировании Excel VBA. У меня есть один лист Excel с двумя столбцами, и в каждом столбце есть несколько адресов электронной почты, разделенных @@. как
ColumA
аа @ yahoo.com @@ бб @ yahoo.com @@ куб.см @ yahoo.com
х @ .com @@ у @ y.com

ColumnB
ZZ @ yahoo.com @@ аа @ yahoo.com
aa@yahoo.com

Как вы можете видеть, что оба столбца имеют две строки, мне нужен третий столбец, который должен содержать все уникальные значения, такие как
ColumnC
аа @ yahoo.com @@ бб @ yahoo.com @@ куб.см @ yahoo.com @ ZZ @ yahoo.com
х @ .com @@ у @ y.com @@ аа @ yahoo.com

Спасибо

Answer 1

Примерно так с вариативными массивами и словарем - эффективный процесс получения желаемого результата

[ обновлено для удаления разделителя в начале строки, код гибкий по длине разделителя]Так что, похоже, убрал возможность загружать изображение, поэтому моя картинка отвалилась ....

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

Вот мой дубль.Как это работает:

1. Дамп столбцов A и B в массив вариантов
2. Объедините каждую строку, разбейте на массив электронных писем, а затем отсеивайте ошибки со словарем.
3. Объединение уникального списка в одну строку и сохранение в новом массиве
4. Транспонирование нового массива в столбец 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

Примечание : Это довольно похоже на ответ brettdj, но есть несколько отличий, о которых стоит упомянуть:

• Я использовал более значимые имена для переменных (для удобства чтения и облегчения редактирования)
• Я очищаю "@@" в начале предложения
• Я использую новый массив, а не перезаписываю значения существующего
• Я выбираю очиститьсловарь после каждой ячейки
• Я предпочитаю использовать «при возобновлении ошибки далее» и просто сбрасывать записи в словарь вместо проверки, существуют они или нет (личные предпочтения не имеют большого значения)

Answer 3

Самый простой способ сделать это - использовать объект словаря , , функцию разделения и , функцию соединения . Конечно, вам не нужно использовать именно эти, но попробуйте и посмотрите, что вы получите.