[已解决]需要个VBA才能解决

zhaongxa

数据.rar (99.97 KB, 下载次数: 25)

2013-3-22 11:29 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-3-22 14:01

注释两句就成了。

1. Sub 提取()
   
2.     '源数据，结果数组，记录个数，临时数组
   
3.     Dim arr, result(1 To 65536, 1 To 1), lCount&, arrTemp
   
4. 
   
5.     '字典数组
   
6.     Dim a, b, arrCount()
   
7. 
   
8.     '取源数据
   
9.     arr = Range("g3").CurrentRegion
   
10.     '定义字典数组
    
11.     ReDim arrCount(1 To UBound(arr, 2))
    
12.     '临时字典
    
13.     Dim dic As Object
    
14.     'Set dic = CreateObject("scripting.dictionary")
    
15.     'Set dic2 = CreateObject("scripting.dictionary")
    
16. 
    
17.     For i = LBound(arr, 2) To UBound(arr, 2)
    
18.         '每列数据一个字典
    
19.         Set arrCount(i) = CreateObject("scripting.dictionary")
    
20.         Set dic = arrCount(i)
    
21.         '取指定列数据
    
22.         arrTemp = WorksheetFunction.Index(arr, 0, i)
    
23.         '统计重复个数
    
24.         For Each a In arrTemp
    
25.             If Len(a) = 0 Then Exit For
    
26.             dic(a) = dic(a) + 1
    
27.         Next
    
28.         Set dic = Nothing
    
29.     Next
    
30. 
    
31.     '根据重复次数统计每列符合条件的数据，另外再统计达到5次要求的。
    
32.     '临时字典,求有5次重复的数据
    
33.     For j = 2 To 6
    
34.         Set dic = CreateObject("scripting.dictionary")
    
35.         '遍历每列统计结果
    
36.         For Each a In arrCount
    
37.             For Each b In a.keys
    
38.                 If a(b) = j Then
    
39.                     'lCount = lCount + 1
    
40.                     'result(lCount, 1) = "'" & b
    
41.                     dic(b) = dic(b) + 1
    
42.                 End If
    
43.             Next
    
44.         Next
    
45. 
    
46.         '遍历所有列相同数据的重复次数
    
47.         For Each a In dic.keys
    
48.             If dic(a) = 5 Then
    
49.                 lCount = lCount + 1
    
50.                 result(lCount, 1) = "'" & a
    
51.             End If
    
52.         Next
    
53.         Set dic = Nothing
    
54.     Next
    
55. 
    
56.     Range("a1").Resize(lCount) = result
    
57. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

还是用字典去解决吧。

zhaongxa

hwc2ycy 发表于 2013-3-22 11:35
还是用字典去解决吧。

我不会,你能帮忙吗?

hwc2ycy

G列重复2次的数,H列重复2次的数,I列重复2次的数,J列重复2次的数,K列重复2次的数,这些数再重复5次的数放A列，再重复5次，你直接都判断重复5次不就得了，               

zhaongxa

hwc2ycy 发表于 2013-3-22 12:29
G列重复2次的数,H列重复2次的数,I列重复2次的数,J列重复2次的数,K列重复2次的数,这些数再重复5次的数放A列， ...

我想要的是G到K这五列的每列都重2次的数里再相同的数, 例G重2次有123,478, H重2次有045,123, I重2次有123, J重2次有369,123,489, K重2次有123,  要的结果就是123

hwc2ycy

1. Sub 提取()
   
2.     '源数据，结果数组，记录个数，临时数组
   
3.     Dim arr, result(1 To 65536, 1 To 1), lCount&, arrTemp
   
4.    
   
5.     '字典数组
   
6.     Dim a, b, arrCount()
   
7. 
   
8.     '取源数据
   
9.     arr = Range("g3").CurrentRegion
   
10.     '定义字典数组
    
11.     ReDim arrCount(1 To UBound(arr, 2))
    
12.     '临时字典
    
13.     Dim dic As Object
    
14.     'Set dic = CreateObject("scripting.dictionary")
    
15.     'Set dic2 = CreateObject("scripting.dictionary")
    
16. 
    
17.     For i = LBound(arr, 2) To UBound(arr, 2)
    
18.         '每列数据一个字典
    
19.         Set arrCount(i) = CreateObject("scripting.dictionary")
    
20.         Set dic = arrCount(i)
    
21.         '取指定列数据
    
22.         arrTemp = WorksheetFunction.Index(arr, 0, i)
    
23.         '统计重复个数
    
24.         For Each a In arrTemp
    
25.             If Len(a) = 0 Then Exit For
    
26.             dic(a) = dic(a) + 1
    
27.         Next
    
28.         Set dic = Nothing
    
29.     Next
    
30. 
    
31.     '根据重复次数统计每列符合条件的数据，另外再统计达到5次要求的。
    
32.     '临时字典,求有5次重复的数据
    
33.     For j = 2 To 6
    
34.         Set dic = CreateObject("scripting.dictionary")
    
35.         '遍历每列统计结果
    
36.         For Each a In arrCount
    
37.             For Each b In a.keys
    
38.                 If a(b) = j Then
    
39.                     lCount = lCount + 1
    
40.                     result(lCount, 1) = "'" & b
    
41.                     dic(b) = dic(b) + 1
    
42.                 End If
    
43.             Next
    
44.         Next
    
45. 
    
46.         '遍历所有列相同数据的重复次数
    
47.         For Each a In dic.keys
    
48.             If dic(a) >= 5 Then
    
49.                 lCount = lCount + 1
    
50.                 result(lCount, 1) = "'" & a
    
51.             End If
    
52.         Next
    
53.         Set dic = Nothing
    
54.     Next
    
55.    
    
56.     Range("a1").Resize(lCount) = result
    
57.     MsgBox "统计完成"
    
58. End Sub
    

复制代码

hwc2ycy

所有列相同数据的重复次数我是用的只要5次或5次以上的就成，不知合你的要求不。

hwc2ycy

如果是只要出现5次的，就改下条件

1.         '遍历所有列相同数据的重复次数
   
2.         For Each a In dic.keys
   
3.             If dic(a) >= 5 Then
   
4.                 lCount = lCount + 1
   
5.                 result(lCount, 1) = "'" & a
   
6.             End If
   
7.         Next

复制代码

改为

1.         '遍历所有列相同数据的重复次数
   
2.         For Each a In dic.keys
   
3.             If dic(a) = 5 Then
   
4.                 lCount = lCount + 1
   
5.                 result(lCount, 1) = "'" & a
   
6.             End If
   
7.         Next

复制代码

zhaongxa

hwc2ycy 发表于 2013-3-22 13:41
如果是只要出现5次的，就改下条件改为

有一点小问题 数据.rar (53.86 KB, 下载次数: 5)

2013-3-22 13:50 上传

点击文件名下载附件

hwc2ycy

你只要共同重复的数据哦。