《提取重复数据中的不重复记录》这个题目好绕啊，呵呵，也就是身份证列出现两次（含）以上的，把这些数据找出来再去重。。
Sub 查询重复中的不重复记录2() '先排序再查找
    Dim arr(), brr(), MyR&, MyC&, k&, s&
    arr = Range("A1").CurrentRegion.Value
    ReDim brr(1 To UBound(arr), 1 To 3)
    With Worksheets("基本信息").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("C1")
        .SetRange Range("B1:D" & Cells(Rows.Count, 3).End(xlUp).Row)
        .Header = xlYes
        .Apply
    End With
    For MyR = 2 To UBound(arr)
        If arr(MyR, 3) = arr(MyR - 1, 3) Then
            k = k + 1
            If k = 1 Then
                s = s + 1
                For MyC = 1 To 3
                    brr(s, MyC) = arr(MyR - 1, MyC + 1)
                Next MyC
            End If
        Else
            k = 0
        End If
    Next MyR
    Range("F2").Resize(s, 3) = brr
End Sub

Sub 去重2() '船长的思路
    Dim d1 As New Dictionary
    Dim d2 As New Dictionary
    Dim Arr
    Dim arr2
    Dim i As Long
    Dim k As Long
    Arr = Range("B2:D9")
    ReDim arr2(1 To UBound(Arr, 1), 1 To 3)
    For i = 1 To UBound(Arr, 1)
        If d1.Exists(Arr(i, 3)) Then
            If Not d2.Exists(Arr(i, 3)) Then
                k = k + 1
                arr2(k, 1) = Arr(i, 1)
                arr2(k, 2) = Arr(i, 2)
                arr2(k, 3) = Arr(i, 3)
                d2(Arr(i, 3)) = ""
            End If
        Else
            d1(Arr(i, 3)) = ""
        End If
    Next i
    Range("F2").Resize(k, 3) = arr2
End Sub