VBA只保留出现过一次的

困顿的人

本人是一名VBA爱好者  最近工作遇到了技术难题 在附件表格中 有重复的身份证号和姓名，要求删除身份证号和姓名同时出现两次以上的数据，其他数据保留 跪求大神

困顿的人

麻烦各位大神出手相助 小弟试了很多办法 全部失败

蓝桥玄霜

重复的例子：

盼盼198310

.............

困顿的人

盼盼198310 发表于 2022-12-28 16:49
.............

出现两次的数据要删除 而不是保留 比如
金正        男        310102195202032813 这组数据出现了两次 两个数据都删除 不保留

shiruiqiang

困顿的人 发表于 2022-12-29 09:36
出现两次的数据要删除 而不是保留 比如
金正        男        310102195202032813 这组数据出现了两次 两个数据都删除 ...

再判断一句:dic.count>1，dic.key remove

于箱长

困顿的人 发表于 2022-12-29 09:36
出现两次的数据要删除 而不是保留 比如
金正        男        310102195202032813 这组数据出现了两次 两个数据都删除 ...

字典的remove了解一下

困顿的人

于箱长 发表于 2022-12-29 10:03
字典的remove了解一下

Sub test()
    Dim arr, i, d, mkey, skey
    Dim num As Long
    Dim n
    Dim brr
    With Sheets("重复数据")
        arr = .Range("a2:o" & .[d65536].End(xlUp).Row)
        num = .[d65536].End(xlUp).Row
    End With
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        d(arr(i, 4)) = d(arr(i, 4)) + 1
        For n = 1 To 15
        d(arr(i, 4)).Item = d(arr(i, 4)).Item & "," & arr(i, n)
        
        Next
        
    Next
    For Each mkey In d.keys
        If d(mkey) > 1 Then d.Remove mkey
    Next
    If d.Count > 0 Then _
    Sheets ("重复数据"), Range("a1:o" & num).ClearContents
    ReDim brr(1 To d.Count)
    For n = 1 To d.Count
    brr(n) = VBA.Split(d(arr(n, 4)).Item, ",")
   
    Next
   
    Sheets("重复数据").Range("a2").Resize(UBound(d.keys) + 1, 15) = Application.WorksheetFunction.Transpose(brr)
End Sub

实在想不出来了 麻烦老师指导

ykcbf1100

这样就可以。

于箱长

ykcbf1100 发表于 2022-12-29 10:40
这样就可以。

好机智的想法，又Get到一个思路