[已解决]提取重复中的不重复数据

张雄友

提取重复中的不重复数据。

'问题有二点：
'重复记录中的不重复，就是重复的只要一条记录就可以了。
'表头不能自动提取

最佳答案

月排行榜 / 总排行榜

grf1973

2014-5-4 09:22

1. Sub 提取重复中的不重复记录()
   
2.     time1 = Timer
   
3.     ar = Sheets("基本信息").Range("B1:D" & Sheets("基本信息").Cells(Rows.Count, 2).End(3).Row)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
7.     For i = 2 To UBound(ar)
   
8.         xkey = ar(i, 3)
   
9.         d(xkey) = d(xkey) + 1   '记录重复次数
   
10.         If Not d1.exists(xkey) Then d1(xkey) = i   '记录首次出现的行数
    
11.         If d(xkey) = 2 Then
    
12.             k = k + 1
    
13.             For j = 1 To UBound(ar, 2)
    
14.                 br(k, j) = ar(d1(xkey), j)
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     With Sheets("重复")
    
19.         .UsedRange.ClearContents
    
20.         .Cells(1, 2).Resize(1, UBound(ar, 2)) = Application.Index(ar, 1)
    
21.         .Cells(2, 2).Resize(k, UBound(ar, 2)) = br
    
22.     End With
    
23.     Application.StatusBar = "耗时：" & Format(Timer - time1, "0.00") & "秒" '在状态栏左下角生成耗时时间。
    
24. End Sub
    
25. 
    
26. 
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 提取重复中的不重复记录()
   
2.     time1 = Timer
   
3.     ar = Sheets("基本信息").Range("B1:D" & Sheets("基本信息").Cells(Rows.Count, 2).End(3).Row)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
7.     For i = 2 To UBound(ar)
   
8.         xkey = ar(i, 3)
   
9.         d(xkey) = d(xkey) + 1   '记录重复次数
   
10.         If Not d1.exists(xkey) Then d1(xkey) = i   '记录首次出现的行数
    
11.         If d(xkey) = 2 Then
    
12.             k = k + 1
    
13.             For j = 1 To UBound(ar, 2)
    
14.                 br(k, j) = ar(d1(xkey), j)
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     With Sheets("重复")
    
19.         .UsedRange.ClearContents
    
20.         .Cells(1, 2).Resize(1, UBound(ar, 2)) = Application.Index(ar, 1)
    
21.         .Cells(2, 2).Resize(k, UBound(ar, 2)) = br
    
22.     End With
    
23.     Application.StatusBar = "耗时：" & Format(Timer - time1, "0.00") & "秒" '在状态栏左下角生成耗时时间。
    
24. End Sub
    
25. 
    
26. 
    

复制代码

grf1973

请看附件。用2个字典，字典1记录重复次数，当重复次数为2时取出对应内容；字典2记录首次出现的行数（主要因为重复内容的序号不一致）。

张雄友

grf1973 发表于 2014-5-4 09:26
请看附件。用2个字典，字典1记录重复次数，当重复次数为2时取出对应内容；字典2记录首次出现的行数（主要因 ...

        .Cells(1, 2).Resize(1, UBound(ar, 2)) = Application.Index(ar, 1)

红字的二个参数是怎么用的？

grf1973

Application.Index(ar, k)  表示取数组ar的第k行
Application.Index(ar,, k)  表示取数组ar的第k列

sayloveyou2010

1. 
   
2. Sub 查询()
   
3.     Dim Dic As Object, Arr(), brr(),MyR&, MyC%, k%
   
4.     Set Dic = CreateObject("scripting.dictionary")
   
5.     Arr = Sheets("基本信息").UsedRange.Value
   
6.     ReDim brr(1 To UBound(Arr), 1 To 3)
   
7.     For MyR = 1 To UBound(Arr)
   
8.         If Not Dic.Exists(Arr(MyR, 3)) Then
   
9.             k = k + 1
   
10.             Dic.Add Arr(MyR, 3), k
    
11.             For MyC = 1 To 3
    
12.                 brr(k, MyC) = Arr(MyR, MyC)
    
13.             Next MyC
    
14.         End If
    
15.     Next MyR
    
16.     Sheets("效果").Columns("d").NumberFormatLocal = "@"
    
17.     Sheets("效果").Range("B1").Resize(k, 3) = brr
    
18. End Sub
    

复制代码

张雄友

sayloveyou2010 发表于 2014-5-4 09:39

完全错误。

sayloveyou2010

张雄友 发表于 2014-5-4 09:44
完全错误。

结果错误 ？

张雄友

sayloveyou2010 发表于 2014-5-4 09:49
结果错误 ？

你没认真看问题。

sayloveyou2010

张雄友 发表于 2014-5-4 09:52
你没认真看问题。

{:101:}可能还没睡醒，一会儿有时间再看看