[分享]用字典提取重复与不重复数据

hhzjxss · 发表于 2007-11-17 00:01

问题已解决，答案在5楼！

请问：

“temp”表中有许多数据，其中黄色的表示重复的数据。

8lBg0oy0.rar (10.77 KB, 下载次数: 51)

hhzjxss · 发表于 2007-11-17 00:01

下面的是oobird版主在另一个帖子给我的代码，我不懂，请大家帮忙修改一下！

原贴位置：

http://club.excelhome.net/dispbbs.asp?boardid=2&id=276869

代码：

Option Explicit

Sub 提取数据()
Dim rng, d As Object, d2 As Object, i%, j%, s$, arr1, arr2, t
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
rng = Sheets("temp").UsedRange
For i = 1 To UBound(rng) 'UBound 函数,返回一个 Long 型数据，其值为指定的数组维可用的最大下标。
For j = 1 To 5
s = s & "," & rng(i, j)
Next j
    If Not d.exists(s) Then
    d.Add s, i: s = ""
    Else
     If Not d2.exists(s) Then
    d2.Add s, i: d.Remove (s): s = ""
          End If
          End If
Next
If d2.Count > 0 Then
ReDim arr1(1 To d2.Count, 1 To 16)
t = d2.keys
For i = 1 To d2.Count
For j = 1 To 5
arr1(i, j) = Split(t(i - 1), ",")(j)
Next j
Next i
Sheets("重复").[a1].Resize(d2.Count, 5) = arr1
End If
If d.Count > 0 Then
ReDim arr2(1 To d.Count, 1 To 5)
t = d.keys
For i = 1 To d.Count
For j = 1 To 5
arr2(i, j) = Split(t(i - 1), ",")(j)
Next j
Next i
Sheets("不重复").[a1].Resize(d.Count, 5) = arr2
End If
    MsgBox "提取完毕！"
End Sub

djyjysxxs · 发表于 2007-11-17 00:30

看这样改对不：

Sub 提取数据()
Dim rng, d As Object, d2 As Object, i%, j%, s$, arr1, arr2, t
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
rng = Sheets("temp").UsedRange
For i = 1 To UBound(rng) 'UBound 函数,返回一个 Long 型数据，其值为指定的数组维可用的最大下标。
For j = 1 To 5
s = s & "," & rng(i, j)
Next j
    If Not d.exists(rng(i, 2)) Then
    d(rng(i, 2)) = s: s = ""
    Else
     d2(rng(i, 2)) = d(rng(i, 2)) & rng(i, 5)
     d.Remove (rng(i, 2))
     s = ""
     End If
Next
If d2.Count > 0 Then
ReDim arr1(1 To d2.Count, 1 To 16)
t = d2.items
For i = 1 To d2.Count
For j = 1 To 5
arr1(i, j) = Split(t(i - 1), ",")(j)
Next j
Next i
Sheets("重复").[a2].Resize(d2.Count, 5) = arr1
End If
If d.Count > 0 Then
ReDim arr2(1 To d.Count, 1 To 5)
t = d.items
For i = 1 To d.Count
For j = 1 To 5
arr2(i, j) = Split(t(i - 1), ",")(j)
Next j
Next i
Sheets("不重复").[a1].Resize(d.Count, 5) = arr2
End If
    MsgBox "提取完毕！"
End Sub

hhzjxss · 发表于 2007-11-17 00:37

谢谢天堂鼠兄了，先测试一下看看！

hhzjxss · 发表于 2007-11-17 00:51

谢谢天堂鼠兄了，测试成功了！

传上来与大家共享！

PlyqK7xl.rar (17.27 KB, 下载次数: 142)

hhzjxss · 发表于 2007-11-17 00:55

看来非学字典不可了！

hhzjxss · 发表于 2007-11-17 09:05

原来提问的帖子在这里：

1.

[求助]（hhzjxss 雨中漫步）请进！欢迎大家参与！
作者：mxg825 浏览：67 回复：6 → 『VBA开发兴趣小组』 2007-11-15 12:48:00

mxg825 · 发表于 2007-11-17 17:00

表1或表2 的数据超过28行就不行！

oobird · 发表于 2007-11-17 21:29

yOXEziC0.rar (11.36 KB, 下载次数: 67)

hhzjxss · 发表于 2007-11-18 08:58

QUOTE:

以下是引用oobird在2007-11-17 21:29:00的发言：

试试。

oobird版主，你终于来了，啥时开贴讲一下字典吧！

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