[已解决]查找符合条件并排序

shixyi37

编代码，按条件查找两张源工作表，并将查找到的数据按要求排序拷贝到另一张工作表。详细见附件
查找符合条件.zip (15.63 KB, 下载次数: 13)

2015-2-9 11:15 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2015-2-9 13:01

一个按钮就行了

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, ar, brr, d, d2, i&, m%, j%, k%, s&, jj%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ReDim brr(1 To 50000, 1 To 5)
   
5. w = Array("期中", "期末")
   
6. Sheets("前10名").Activate
   
7. For m = 0 To UBound(w)
   
8.     arr = Sheets(w(m)).Range("a1").CurrentRegion
   
9.     ReDim ar(1 To UBound(arr), 1 To UBound(arr, 2))
   
10.     For i = 3 To UBound(arr)
    
11.         If arr(i, 5) > 120 Or arr(i, 5) < 60 Then
    
12.             s2 = s2 + 1
    
13.             For jj = 1 To UBound(arr, 2)
    
14.                 brr(s2, jj) = arr(i, jj)
    
15.             Next
    
16.         End If
    
17.         If Not d.Exists(arr(i, 3)) Then
    
18.             d(arr(i, 3)) = i
    
19.         Else
    
20.             d(arr(i, 3)) = d(arr(i, 3)) & "," & i
    
21.         End If
    
22.     Next
    
23.     s = 0
    
24.     For j = 1 To 10 '前10名
    
25.         x = Application.Large(d.Keys, j)
    
26.         y = Split(d(x), ",")
    
27.         For k = 0 To UBound(y)
    
28.             s = s + 1
    
29.             For l = 1 To UBound(arr, 2)
    
30.                 ar(s, l) = arr(y(k), l)
    
31.             Next
    
32.         Next
    
33.     Next
    
34.     lie = IIf(m = 0, 1, 7)
    
35.     Cells(4, lie).Resize(s, UBound(ar, 2)) = ar
    
36.     d.RemoveAll
    
37. Next
    
38. Sheets("高于150分").Range("a4").Resize(s2, 5) = brr
    
39. End Sub

复制代码

dsmch

一个按钮就行了

shixyi37

dsmch 发表于 2015-2-9 13:01
一个按钮就行了

谢谢

shixyi37

dsmch 发表于 2015-2-9 13:01
一个按钮就行了

可是我想要两个按钮的，查找前10名一个按钮，查找大于120分小于60分一个按钮，怎么分开呢，

dsmch

1. Sub 查找1()
   
2. Dim arr, ar, d, i&, m%, j%, k%, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. w = Array("期中", "期末")
   
5. Sheets("前10名").Activate
   
6. For m = 0 To UBound(w)
   
7.     arr = Sheets(w(m)).Range("a1").CurrentRegion
   
8.     ReDim ar(1 To UBound(arr), 1 To UBound(arr, 2))
   
9.     For i = 3 To UBound(arr)
   
10.         If Not d.Exists(arr(i, 3)) Then
    
11.             d(arr(i, 3)) = i
    
12.         Else
    
13.             d(arr(i, 3)) = d(arr(i, 3)) & "," & i
    
14.         End If
    
15.     Next
    
16.     s = 0
    
17.     For j = 1 To 10 '前10名
    
18.         x = Application.Large(d.Keys, j)
    
19.         y = Split(d(x), ",")
    
20.         For k = 0 To UBound(y)
    
21.             s = s + 1
    
22.             For l = 1 To UBound(arr, 2)
    
23.                 ar(s, l) = arr(y(k), l)
    
24.             Next
    
25.         Next
    
26.     Next
    
27.     lie = IIf(m = 0, 1, 7)
    
28.     Cells(4, lie).Resize(s, UBound(ar, 2)) = ar
    
29.     d.RemoveAll
    
30. Next
    
31. End Sub
    
32. Sub 查找2()
    
33. Dim arr, brr, m%, i&, j%
    
34. ReDim brr(1 To 50000, 1 To 5)
    
35. w = Array("期中", "期末")
    
36. Sheets("高于150分").Activate
    
37. For m = 0 To UBound(w)
    
38.     arr = Sheets(w(m)).Range("a1").CurrentRegion
    
39.     ReDim ar(1 To UBound(arr), 1 To UBound(arr, 2))
    
40.     For i = 3 To UBound(arr)
    
41.         If arr(i, 5) > 120 Or arr(i, 5) < 60 Then
    
42.             s2 = s2 + 1
    
43.             For j = 1 To UBound(arr, 2)
    
44.                 brr(s2, j) = arr(i, j)
    
45.             Next
    
46.         End If
    
47.     Next
    
48. Next
    
49. Range("a4").Resize(s2, 5) = brr
    
50. End Sub

复制代码

shixyi37

谢谢