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

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. End Sub

复制代码

hwc2ycy

最后用个判断吧，免得0条记录出错。

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.     If lCount > 0 Then Range("a1").Resize(lCount) = result
    
56. End Sub

复制代码

zhaongxa

hwc2ycy 发表于 2013-3-22 14:03
最后用个判断吧，免得0条记录出错。

应该还少了一个条件 数据.rar (54.48 KB, 下载次数: 5)

2013-3-22 14:25 上传

点击文件名下载附件

hwc2ycy

自己改吧，我不想动了，不停的改来改去。

hwc2ycy

你先告诉你这个需求在实际中用做什么？

hwc2ycy

不肯透露下？

zhaongxa

hwc2ycy 发表于 2013-3-22 15:07
不肯透露下？

我的水平看都看不懂,为什么不让自己的作品更完美呢?

hwc2ycy

我这都改好了，你告诉我下，你这实际中做什么用的,{:912:}

zhaongxa

hwc2ycy 发表于 2013-3-22 15:13
我这都改好了，你告诉我下，你这实际中做什么用的,

天呀,这实际上能做什么用,不就是破网题用吗

hwc2ycy

1. Sub 提取()
   
2. 
   
3.     Dim arr, result(1 To 3000, 1 To 1), lCount&, arrTemp
   
4.     Dim a, b, arrCount()
   
5.     Dim i&, k&
   
6. 
   
7.     arr = Range("g3").CurrentRegion
   
8.     ReDim arrCount(1 To 5)
   
9.     Dim dic As Object
   
10.     'Set dic = CreateObject("scripting.dictionary")
    
11.     'Set dic2 = CreateObject("scripting.dictionary")
    
12.     For i = LBound(arr, 2) To UBound(arr, 2) - 4
    
13.         For k = i To i + 4
    
14.             Set arrCount(k - i + 1) = CreateObject("scripting.dictionary")
    
15.             Set dic = arrCount(k - i + 1)
    
16.             arrTemp = WorksheetFunction.Index(arr, 0, k)
    
17. 
    
18.             For Each a In arrTemp
    
19.                 If Len(a) = 0 Then Exit For
    
20.                 dic(a) = dic(a) + 1
    
21.             Next
    
22.             Set dic = Nothing
    
23.         Next
    
24. 
    
25.         For j = 2 To 6
    
26.             Set dic = CreateObject("scripting.dictionary")
    
27.             For Each a In arrCount
    
28.                 For Each b In a.keys
    
29.                     If a(b) = j Then
    
30.                         'lCount = lCount + 1
    
31.                         'result(lCount, 1) = "'" & b
    
32.                         dic(b) = dic(b) + 1
    
33.                     End If
    
34.                 Next
    
35.             Next
    
36. 
    
37.             For Each a In dic.keys
    
38.                 If dic(a) = 5 Then
    
39.                     lCount = lCount + 1
    
40.                     result(lCount, 1) = "'" & a
    
41.                 End If
    
42.             Next
    
43.             Set dic = Nothing
    
44.         Next
    
45.     Next
    
46. 
    
47. If lCount > 0 Then Range("A1").Resize(lCount) = result
    
48. End Sub

复制代码