求excel自动提取重复的宏代码

Question

数据在A列，有部分重复，有10几万行，要求把重复部分提取出来，然后输出到sheet2
由于数据量大，excel2003的65535行不够用，所以代码要写2007版的104W行的~谢谢
在来一个代码：要求筛选A:A中重复的只算一个
比如A1:500 A2:300 A3:1008 A4:300 A5:852
那么在sheet2生成结果A1::500 A2:300 A3:1008 A4:852
重复的300自动删除

Answer 1

       不用编宏这么麻烦啊，Excel 2007提供了名为“删除重复项”的功能，它可以快速删除工作表中的重复数据。

       具体操作方法是：选中可能存在重复数据或记录的区域（你这里直接选中A列就行），单击“数据”选项卡中 的“删除重复项”按钮（如图），然后在弹出的对话框中直接点确定即可。提示的重复项可能比你实际的重复项多，因为它把空白行也算作重复行了，不会影响最后操作结果。

如果是为了操作方便或者要结合其他地方使用的话，EXCEL2007及以上版本可以用这一句：

ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlNo

Answer 2

提取重复的代码

Sub bb()
Dim RowEnd As Long, Dic, JGArr()
RowEnd = Range("A1048576").End(xlUp).Row
Allarr = Range("A1:A" & RowEnd).Value
x = 1
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Allarr)
    Dic(Allarr(i, 1)) = Dic(Allarr(i, 1)) + 1
Next
For Each d In Dic.keys
    If Dic(d) > 1 Then
        n = n + 1
        ReDim Preserve JGArr(1 To n)
        JGArr(n) = d
    End If
    If n > 1 Then
        If n Mod 10000 = 0 Then
            Sheet2.Range("A" & x).Resize(10000, 1) = WorksheetFunction.Transpose(JGArr)
            x = x + 10000
            Erase JGArr
            n = 0
        End If
    End If
Next
If n = 0 Then Exit Sub
Sheet2.Range("A" & x).Resize(10000, 1) = WorksheetFunction.Transpose(JGArr)
End Sub

去除重复的代码

Sub bbb()
Dim RowEnd As Long, Dic, JGArr()
RowEnd = Range("A1048576").End(xlUp).Row
Allarr = Range("A1:A" & RowEnd).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Allarr)
    Dic(Allarr(i, 1)) = Dic(Allarr(i, 1)) + 1
Next
Sheet2.Range("A1").Resize(Dic.count, 1) = WorksheetFunction.Transpose(dic.keys)
End Sub

本回答被提问者采纳

Answer 3

因为你要删除重复记录，excel2007和excel 2010上面都有删除重复项按钮的，你用一下就可以了