[已解决]如何选中重复数据并生成另一个工作表？

森林木007

重复值另存工作表问题2003.zip (8.94 KB, 下载次数: 42)

2013-8-23 14:04 上传

点击文件名下载附件
如何选中重复数据并生成另一个工作表？
今天遇到一个问题，一个2万多个流水重复记录，想用VBA实现即时重复预付款的笔数明细；
1、以姓名与有效证件号码列为唯一值，有重复找出来复制到结果表中；见图示；
2、若有同名的但证件不同--见红色部分，不复制；
请老师帮帮手，谢谢，谢谢！！

最佳答案

月排行榜 / 总排行榜

爱疯

2013-8-23 17:31

Sub test()
    Dim A(), B(), d, i&, j&, s&
   
    A = Sheets(1).Range("a1").CurrentRegion.Value
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set d = CreateObject("scripting.dictionary")
   
   
    For i = 2 To UBound(A)
        d(A(i, 4)) = d(A(i, 4)) + 1
    Next i

    For i = 2 To UBound(A)
        If d(A(i, 4)) > 1 Then
            s = s + 1
            For j = 1 To UBound(A, 2)
                B(s, j) = A(i, j)
            Next j
        End If
    Next i


    With Sheets(2)
        .Range("a2:g65536").Clear
        .Range("d:e").NumberFormatLocal = "000000"
        .Range("a2").Resize(s, UBound(B, 2)) = B
    End With
End Sub

跳转到最佳答案楼层

lyf7276

字典代码你不是写好吗？

森林木007

lyf7276 发表于 2013-8-22 21:43
字典代码你不是写好吗？

附件传错了！
现已经纠正，请查阅！谢谢！

森林木007

请老师帮忙！

森林木007

仔细一想，其实就是以＂有效证件号码＂为关键字筛选出重复值，让后根据关键字复制整行到新表，新表再根据关键字排序即可得到效果；
本人在2010下用颜色自定义，再筛选出重复值排序即可，但数据量大，操作费劲。
所以请高手给一个VBA的解决方案。

爱疯

Sub test()
    Dim A(), B(), d, i&, j&, s&
   
    A = Sheets(1).Range("a1").CurrentRegion.Value
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set d = CreateObject("scripting.dictionary")
   
   
    For i = 2 To UBound(A)
        d(A(i, 4)) = d(A(i, 4)) + 1
    Next i

    For i = 2 To UBound(A)
        If d(A(i, 4)) > 1 Then
            s = s + 1
            For j = 1 To UBound(A, 2)
                B(s, j) = A(i, j)
            Next j
        End If
    Next i


    With Sheets(2)
        .Range("a2:g65536").Clear
        .Range("d:e").NumberFormatLocal = "000000"
        .Range("a2").Resize(s, UBound(B, 2)) = B
    End With
End Sub

森林木007

爱疯 发表于 2013-8-23 17:31
Sub test()
    Dim A(), B(), d, i&, j&, s&
   

谢谢老师帮忙！