[已解决]提取相同数据与删除相同数据

wuliao_tao

提取相同数据与删除相同数据，详见附件，求二段VBA，谢谢。
提取与删除.rar (2.63 KB, 下载次数: 18)

2013-10-14 23:26 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

zjdh

2013-10-15 09:31

提取与删除.rar (10.77 KB, 下载次数: 48)

2013-10-15 09:31 上传

点击文件名下载附件

跳转到最佳答案楼层

zjdh

提取与删除.rar (10.77 KB, 下载次数: 48)

2013-10-15 09:31 上传

点击文件名下载附件

上清宫主

写了一个：
Sub test1()
    Dim arr(), brr()
    i% = Sheets("表一").Range("A65536").End(3).Row
    arr = Sheets("表一").Range("A3").Resize(i - 2, 2).Value
    ReDim Preserve arr(1 To i - 2, 1 To i)
    i% = Sheets("表二").Range("A65536").End(3).Row
    brr = Sheets("表二").Range("A2").Resize(i - 1, 1).Value
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(brr)
        d(brr(i, 1)) = 0
        brr(i, 1) = 1
    Next
    For i = 1 To UBound(arr)
        If d.exists(arr(i, 1)) Then
           If d(arr(i, 1)) < 1 Then
              j = j% + 1
              d(arr(i, 1)) = j
              arr(d(arr(i, 1)), 1) = arr(i, 1)
            End If
            brr(d(arr(i, 1)), 1) = brr(d(arr(i, 1)), 1) + 1
            arr(d(arr(i, 1)), brr(d(arr(i, 1)), 1)) = arr(i, 2)
            If maxa < brr(d(arr(i, 1)), 1) Then maxa = brr(d(arr(i, 1)), 1)
         End If
    Next
    Sheets("表三").Range("A2:Z65536").ClearContents
    Sheets("表三").Range("A2").Resize(j, maxa) = arr
End Sub

wuliao_tao

很好用，谢谢，但测试了一下，有一点有问题，就是如果无相同的数据，就会出错，请修改一下。谢谢 。

zjdh

wuliao_tao 发表于 2013-10-15 21:28
很好用，谢谢，但测试了一下，有一点有问题，就是如果无相同的数据，就会出错，请修改一下。谢谢 。

加一句判断
Sub TQ()
    ARR = Sheets("表一").Range("A3:B" & Sheets("表一").Range("A65536").End(3).Row)
    BRR = Sheets("表二").Range("A2:A" & Sheets("表二").Range("A65536").End(3).Row)
    Set d = CreateObject("scripting.dictionary")
    For I = 1 To UBound(BRR)
        For J = 1 To UBound(ARR)
            If BRR(I, 1) = ARR(J, 1) Then
                If Not d.exists(BRR(I, 1)) Then
                    d(BRR(I, 1)) = ARR(J, 2)
                Else
                    d(BRR(I, 1)) = d(BRR(I, 1)) & "|" & ARR(J, 2)
                End If
            End If
        Next
    Next
    K = d.KEYS
    If d.Count = 0 Then MsgBox "没有相同姓名！": Exit Sub
    ReDim ZH(1 To d.Count, 1 To 26)
    With Sheets("表三")
        .Range("A2:Z65536").ClearContents
        For I = 0 To UBound(K)
            Z = Split(d(K(I)), "|")
            ZH(I + 1, 1) = K(I)
            For J = 0 To UBound(Z)
                ZH(I + 1, J + 2) = Z(J)
            Next
        Next
        .Range("A2").Resize(UBound(ZH), 26) = ZH
    End With
End Sub