[已解决]多行多列提取重复记录

张雄友 · 发表于 2014-6-6 20:19

本帖最后由张雄友于 2014-6-6 21:48 编辑

多行多列提取重复记录。

最佳答案

cbg2008

2014-6-6 20:38

Sub 多行多列提取重复记录()
Dim arr As Variant, i As Long, j As Byte, k As Long, d1 As Object, d2 As Object, b As Variant
k = -1
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("A1:E14").Value
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Not IsError(arr(i, j)) Then '此处当是错误值时，原arr(i, j) <> ""就会类型不匹配
If d1.exists(arr(i, j)) And arr(i, j) <> "" Then
d2(arr(i, j)) = ""
Else
d1(arr(i, j)) = ""
End If
End If
Next j
Next i
kk = d2.keys
ReDim b(1 To d2.Count, 1 To 1)
For i = 0 To d2.Count - 1 '不用transpose就用循环来转置，而且transpose对数组尺寸和字符长度有限止，循环没问题
b(i + 1, 1) = kk(i)
Next i
Range("H2:H10000").ClearContents
Range("H2").Resize(UBound(b)) = b
End Sub

复制代码

cbg2008 · 发表于 2014-6-6 20:38

Sub 多行多列提取重复记录()
Dim arr As Variant, i As Long, j As Byte, k As Long, d1 As Object, d2 As Object, b As Variant
k = -1
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("A1:E14").Value
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Not IsError(arr(i, j)) Then '此处当是错误值时，原arr(i, j) <> ""就会类型不匹配
If d1.exists(arr(i, j)) And arr(i, j) <> "" Then
d2(arr(i, j)) = ""
Else
d1(arr(i, j)) = ""
End If
End If
Next j
Next i
kk = d2.keys
ReDim b(1 To d2.Count, 1 To 1)
For i = 0 To d2.Count - 1 '不用transpose就用循环来转置，而且transpose对数组尺寸和字符长度有限止，循环没问题
b(i + 1, 1) = kk(i)
Next i
Range("H2:H10000").ClearContents
Range("H2").Resize(UBound(b)) = b
End Sub

复制代码

		自动登录	找回密码
密码			注册