当前位置：文江博客话题详情

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

发布于 2024-12-10 13:23:40 字数 1952 浏览 0 评论 0原文

我是 Excel VBA 编程新手。我有一个包含两列的 Excel 工作表，每列都有一些用 @@ 分隔的电子邮件地址。喜欢
A栏
[电子邮件受保护]@@[电子邮件受保护]@@[电子邮件;受保护]
[电子邮件受保护]@@[电子邮件受保护]

ColumnB
[电子邮件受保护]@@[电子邮件受保护]
[email protected]

如您所见，两列都有两个行，我需要第三列，其中应包含所有唯一值，例如
C栏
[电子邮件受保护]@@[电子邮件受保护]@@[电子邮件受保护]@[电子邮件受保护]
[电子邮件受保护]@@[电子邮件受保护]@@[电子邮件;受保护]

谢谢

原文

分享到QQ

分享到微博

如果你对这篇内容有疑问，欢迎到本站社区发帖提问参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。

发布评论

需要登录才能够评论，你可以免费注册一个本站的账号。

碍人泪离人颜 2024-12-17 13:23:40

像这样的变体数组和字典是获得所需结果的有效过程

[更新以删除字符串前面的分隔符，代码在分隔符长度上是灵活的]
所以似乎已经删除了上传图像的功能，所以我的照片已经脱落了....

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

Something like this with variant arrays and a dictionary is an efficient process of getting your desired outcome

[updated to remove delimiter at front of string, code is flexible on delimiter length]
SO seems to have removed the ability to upload image so my picture has fallen off ....

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

回复收藏 0 原文

夜血缘 2024-12-17 13:23:40

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

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

我对变量使用了更有意义的名称（为了可读性并使其更易于编辑）
我确实清理了句子开头的“@@”
我使用一个新数组而不是覆盖现有数组的值
我选择在每个单元格后清除字典
我选择使用“错误恢复下一个”并将条目转储到字典中而不是检查它们是否存在（个人）偏好，使得没有重大区别）

Here's my take. How it works:

Dump columnA and B into a variant array
Combine each row, split into an array of emails, then weed out dupes with a dictionary.
Combine unique list into a single string and store in a new array
Transpose the new array onto column 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:
It's fairly similar to brettdj's answer, but there are a few differences worth mentioning:

I used more meaninful names for variables (for readability and to make it easier to edit)
I do clean up of the "@@" at the start of the sentence
I use a new array rather than overwrite the values of an existing one
I choose to clear the dictionary after each cell
I choose to use "on error resume next" and just dump entries into the dictionary instead of checking if they exist or not (personal preference, makes no major difference)

回复收藏 0 原文