Question

我是Excel VBA编程的新手。我有一个带有两列的excel表，每列有一些由@@分隔的电子邮件地址。像
的 ColumA
AA @ @@ yahoo.com BB @ @@ yahoo.com立方厘米@ yahoo.com
X @ @@ .COMÿ@ y.com

ColumnB
ZZ @ yahoo.com @@ AA @ yahoo.com
aa@yahoo.com

正如您所看到的，两列都有两行，我需要第三列，其中应包含所有唯一值，例如
的 ColumnC
AA @ @@ yahoo.com BB @ @@ yahoo.com立方厘米@ yahoo.com @ ZZ @ yahoo.com
X @ @@ .COMÿ@ @@ y.com AA @ 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

这是我的看法。工作原理：

将columnA和B转储到变量数组
合并每一行，拆分成一组电子邮件，然后用字典淘汰dupes。
将唯一列表合并为单个字符串并存储在新数组中
将新阵列转置到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的答案非常相似，但有一些值得一提的差异：

我为变量使用了更多有意义的名称（为了便于阅读并使其更容易编辑）

我会在句子开头清理“@@”

我使用新数组而不是覆盖现有数组的值

我选择在每个单元格后清除字典

我选择使用“on next resume next”并将条目转储到字典中，而不是检查它们是否存在（个人偏好，没有重大区别）

Answer 3

最简单的方法是使用dictionary object，split function和join function。当然，你不需要使用那些确切的，但试一试，看看你得到了什么。

如何使用vba从excel中的2列中删除重复值

3 个答案: