[已解决]求助

hwc2ycy

1. Sub 提取()
   
2.     Dim arr, i, j, k As Long
   
3.     Dim dic1 As Object, dic2   As Object, dic3 As Object, dic4 As Object
   
4.     Set dic1 = CreateObject("scripting.dictionary")
   
5.     Set dic2 = CreateObject("scripting.dictionary")
   
6.     Set dic3 = CreateObject("scripting.dictionary")
   
7.     Set dic4 = 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: dic4(arr(i, j)) = dic4(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: dic4(arr(i, j)) = dic4(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: dic4(arr(i, j)) = dic4(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) = "'" & i
    
27.         End If        End If
    
28.     Next
    
29. 
    
30.     For Each i In dic2.keys
    
31.         If Val(dic2(i)) > 0 And Val(dic2(i)) < 3 Then
    
32.             k = k + 1
    
33.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
34.             arrRst(1, k) = "'" & i
    
35.         End If
    
36.     Next
    
37. '
    
38.     For Each i In dic3.keys
    
39.         If Val(dic3(i)) > 0 And Val(dic3(i)) < 2 Then
    
40.             k = k + 1
    
41.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
42.             arrRst(1, k) = "'" & i
    
43.         End If
    
44.     Next
    
45.     For Each i In dic4.keys
    
46.         If Val(dic4(i)) > 3 And Val(dic4(i)) < 6 Then
    
47.             k = k + 1
    
48.             ReDim Preserve arrRst(1 To 1, 1 To k)
    
49.             arrRst(1, k) = "'" & i
    
50.         End If
    
51.     Next
    
52.     Range("a1").Resize(k) = Application.WorksheetFunction.Transpose(arrRst)
    
53. End Sub

复制代码

hwc2ycy

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
    

复制代码

hwc2ycy

结果一共是328个数，楼主，你看对不。