[已解决]求助

oplkj

VBA求助 Book2.xls12.rar (9.54 KB, 下载次数: 24)

2012-10-19 14:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-10-20 10:24

1. Sub 提取2()
   
2.     Dim arr, i, j, k As Long, l
   
3.     Dim arrDic(1 To 4, 1 To 3), arrCon
   
4.     For i = 1 To 4
   
5.         Set arrDic(i, 1) = CreateObject("scripting.dictionary")
   
6.     Next
   
7.     arrDic(1, 2) = 1
   
8.     arrDic(1, 3) = 5
   
9.     arrDic(2, 2) = 0
   
10.     arrDic(2, 3) = 3
    
11.     arrDic(3, 2) = 0
    
12.     arrDic(3, 3) = 2
    
13.     arrDic(4, 2) = 3
    
14.     arrDic(4, 3) = 6
    
15.         Dim arrRst() As String
    
16.     arr = Range("f13").CurrentRegion
    
17.     For i = 1 To UBound(arr)
    
18.         For j = 1 To UBound(arr, 2)
    
19.             Select Case j
    
20.                 Case 1, 4, 7, 10, 13
    
21.                     If arr(i, j) <> "" Then arrDic(1, 1)(arr(i, j)) = arrDic(1, 1)(arr(i, j)) + 1: arrDic(4, 1)(arr(i, j)) = arrDic(4, 1)(arr(i, j)) + 1
    
22.                 Case 2, 5, 8, 11, 14
    
23.                     If arr(i, j) <> "" Then arrDic(2, 1)(arr(i, j)) = arrDic(2, 1)(arr(i, j)) + 1: arrDic(4, 1)(arr(i, j)) = arrDic(4, 1)(arr(i, j)) + 1
    
24.                 Case 3, 6, 9, 12, 15
    
25.                     If arr(i, j) <> "" Then arrDic(3, 1)(arr(i, j)) = arrDic(3, 1)(arr(i, j)) + 1: arrDic(4, 1)(arr(i, j)) = arrDic(4, 1)(arr(i, j)) + 1
    
26.             End Select
    
27.         Next
    
28.     Next
    
29.     For i = 1 To UBound(arrDic)
    
30.         For Each j In arrDic(i, 1).keys
    
31.             l = Val(arrDic(i, 1)(j))
    
32.             If l > arrDic(i, 2) And l < arrDic(i, 3) Then
    
33.                 k = k + 1
    
34.                 ReDim Preserve arrRst(1 To 1, 1 To k)
    
35.                 arrRst(1, k) = "'" & j
    
36.             End If
    
37. 
    
38.         Next
    
39.     Next
    
40.     Range("b1").Resize(k) = Application.WorksheetFunction.Transpose(arrRst)
    
41. End Sub
    

复制代码

跳转到最佳答案楼层

oplkj

求助,求助,求助,求助,

oplkj

oplkj 发表于 2012-10-19 17:43
求助,求助,求助,求助,

求助,求助,求助,求助,

hwc2ycy

这个直接用字典也好解的嘛。

oplkj

hwc2ycy 发表于 2012-10-20 08:58
这个直接用字典也好解的嘛。

我不懂,大师帮出下手吧,

hwc2ycy

1. Sub 提取()
   
2.     Dim arr, i, j, k As Long
   
3.    
   
4.     Dim dic1 As Object, dic2   As Object, dic3 As Object
   
5.     Set dic1 = CreateObject("scripting.dictionary")
   
6.     Set dic2 = CreateObject("scripting.dictionary")
   
7.     Set dic3 = CreateObject("scripting.dictionary")
   
8.     Dim arrRst() As String
   
9.     arr = Range("f13").CurrentRegion
   
10.     For i = 1 To UBound(arr)
    
11.         For j = 1 To UBound(arr, 2)
    
12.             Select Case j
    
13.                 Case 1, 4, 7, 10, 13
    
14.                     If arr(i, j) <> "" Then dic1(arr(i, j)) = dic1(arr(i, j)) + 1
    
15.                 Case 2, 5, 8, 11, 14
    
16.                     If arr(i, j) <> "" Then dic2(arr(i, j)) = dic2(arr(i, j)) + 1
    
17.                 Case 3, 6, 9, 12, 15
    
18.                     If arr(i, j) <> "" Then dic3(arr(i, j)) = dic3(arr(i, j)) + 1
    
19.             End Select
    
20.         Next
    
21.     Next
    
22.     For Each i In dic1.keys
    
23.         If Val(dic1(i)) > 1 And Val(dic1(i)) < 5 Then
    
24.             k = k + 1
    
25.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
26.             arrRst(1, k) = "'" & Format(i, "000")
    
27.         End If
    
28.         If Val(dic1(i)) > 3 And Val(dic1(i)) < 6 Then
    
29.             k = k + 1
    
30.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
31.             arrRst(1, k) = "'" & Format(i, "000")
    
32.         End If
    
33.     Next
    
34.    
    
35.     For Each i In dic2.keys
    
36.         If Val(dic2(i)) > 0 And Val(dic2(i)) < 3 Then
    
37.             k = k + 1
    
38.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
39.             arrRst(1, k) = "'" & Format(i, "000")
    
40.         End If
    
41.         If Val(dic2(i)) > 3 And Val(dic2(i)) < 6 Then
    
42.             k = k + 1
    
43.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
44.             arrRst(1, k) = "'" & Format(i, "000")
    
45.         End If
    
46.     Next
    
47. 
    
48.     For Each i In dic3.keys
    
49.         If Val(dic3(i)) > 0 And Val(dic3(i)) < 2 Then
    
50.             k = k + 1
    
51.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
52.             arrRst(1, k) = "'" & Format(i, "000")
    
53.         End If
    
54.         If Val(dic3(i)) > 3 And Val(dic3(i)) < 6 Then
    
55.             k = k + 1
    
56.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
57.             arrRst(1, k) = "'" & Format(i, "000")
    
58.         End If
    
59.     Next
    
60. 
    
61.     Range("a1").Resize(k) = Application.WorksheetFunction.Transpose(arrRst)
    
62. End Sub

复制代码

hwc2ycy

结果你自己验证，我再优化下代码。

oplkj

hwc2ycy 发表于 2012-10-20 09:43
结果你自己验证，我再优化下代码。

大于3且小于6的指全部列(不分三部分),结果有误

hwc2ycy

1. Sub 提取2()
   
2.     Dim arr, i, j, k As Long, l
   
3.     Dim arrDic(1 To 3, 1 To 3), arrCon
   
4.     For i = 1 To 3
   
5.         Set arrDic(i, 1) = CreateObject("scripting.dictionary")
   
6.     Next
   
7.     arrDic(1, 2) = 1
   
8.     arrDic(1, 3) = 5
   
9.     arrDic(2, 2) = 0
   
10.     arrDic(2, 3) = 3
    
11.     arrDic(3, 2) = 0
    
12.     arrDic(3, 3) = 2
    
13.     arrCon = Array(3, 6)
    
14.     Dim arrRst() As String
    
15.     arr = Range("f13").CurrentRegion
    
16.     For i = 1 To UBound(arr)
    
17.         For j = 1 To UBound(arr, 2)
    
18.             Select Case j
    
19.                 Case 1, 4, 7, 10, 13
    
20.                     If arr(i, j) <> "" Then arrDic(1, 1)(arr(i, j)) = arrDic(1, 1)(arr(i, j)) + 1
    
21.                 Case 2, 5, 8, 11, 14
    
22.                     If arr(i, j) <> "" Then arrDic(2, 1)(arr(i, j)) = arrDic(2, 1)(arr(i, j)) + 1
    
23.                 Case 3, 6, 9, 12, 15
    
24.                     If arr(i, j) <> "" Then arrDic(3, 1)(arr(i, j)) = arrDic(3, 1)(arr(i, j)) + 1
    
25.             End Select
    
26.         Next
    
27.     Next
    
28.     For i = 1 To UBound(arrDic)
    
29.         For Each j In arrDic(i, 1).keys
    
30.             l = Val(arrDic(i, 1)(j))
    
31.             If l > arrDic(i, 2) And l < arrDic(i, 3) Then
    
32.                 k = k + 1
    
33.                 ReDim Preserve arrRst(1 To 1, 1 To k)
    
34.                 arrRst(1, k) = "'" & j
    
35.             End If
    
36.             If l > arrCon(0) And l < arrCon(1) Then
    
37.                 k = k + 1
    
38.                 ReDim Preserve arrRst(1 To 1, 1 To k)
    
39.                 arrRst(1, k) = "'" & j
    
40.             End If
    
41.         Next
    
42.     Next
    
43.     Range("b1").Resize(k) = Application.WorksheetFunction.Transpose(arrRst)
    
44. End Sub
    

复制代码

hwc2ycy

oplkj 发表于 2012-10-20 09:57
大于3且小于6的指全部列(不分三部分),结果有误

哦，明白了。那就还得加加一个字典。