[已解决]提取数据优化代码

张雄友

xpw6061 发表于 2014-4-13 10:27
理解错误,这句是正确的了,上班时间小于8的,排除在外,另选10人最高的

怎么去掉 desc 答案还是一样的？怎么得最低？看下360加速球，占用了80%的内存。

dsmch

常规写法也就是0.2s

1. Sub Macro1()
   
2. Dim rng As Range, arr, brr(1 To 20000, 1 To 11), d, i&, n&, s%
   
3. t = Timer
   
4. Application.ScreenUpdating = False
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Sheets("明细").Activate
   
7. Set rng = [a1:o615]
   
8. arr = rng
   
9. Sheets("明细").FilterMode = False
   
10. For i = 2 To UBound(arr)
    
11.     If Not d.exists(arr(i, 2)) Then
    
12.         d(arr(i, 2)) = ""
    
13.         rng.Sort Key1:=Range("j2"), Order1:=xlDescending, Header:=xlGuess
    
14.         Range("a1").AutoFilter Field:=2, Criteria1:=arr(i, 2)
    
15.         s = 0
    
16.         For Each m In [b2:b615].SpecialCells(xlCellTypeVisible)
    
17.             s = s + 1
    
18.             If s < 11 Then
    
19.                 h = m.Row
    
20.                 n = n + 1
    
21.                 brr(n, 1) = Cells(h, 2)
    
22.                 brr(n, 2) = Cells(h, 4)
    
23.                 brr(n, 3) = Cells(h, 5)
    
24.                 brr(n, 4) = Cells(h, "h")
    
25.                 brr(n, 5) = Cells(h, "i")
    
26.                 brr(n, 9) = Cells(h, "j")
    
27.                 brr(n, 10) = Cells(h, "l")
    
28.                 brr(n, 11) = Cells(h, "m")
    
29.                 If s = 10 Then n = n + 1: brr(n, 1) = arr(i, 2) & "  10人 "
    
30.             End If
    
31.         Next
    
32.     End If
    
33. Next
    
34. ActiveSheet.ShowAllData
    
35. Sheet1.Range("a2").Resize(n, UBound(brr, 2)) = brr
    
36. rng = arr
    
37. MsgBox Timer - t
    
38. Application.ScreenUpdating = True
    
39. End Sub
    

复制代码

张雄友

dsmch 发表于 2014-4-15 14:11
常规写法也就是0.2s

怎么顺序不一样？答案也不对。如工号234880，上班时间小于8，是不分析进去的。

张雄友

dsmch 发表于 2014-4-15 14:11
常规写法也就是0.2s

上班时间大于等于8。

dsmch

用时0.12s

1. Sub Macro1()
   
2. Dim rng As Range, arr, brr(1 To 20000, 1 To 11), i&, n&, s%
   
3. t = Timer
   
4. Application.ScreenUpdating = False
   
5. Sheets("明细").Activate
   
6. Set rng = [a1:o615]
   
7. arr = rng
   
8. w = Array("3A", "3B", "3C", "2G", "2H", "2J", "A1", "A2", "B1")
   
9. Sheets("明细").FilterMode = False
   
10. rng.Sort Key1:=Range("j2"), Order1:=xlDescending, Header:=xlGuess
    
11. For i = 0 To UBound(w)
    
12.     Range("a1").AutoFilter Field:=2, Criteria1:=w(i)
    
13.     [l1].AutoFilter Field:=12, Criteria1:=">=" & 8
    
14.     s = 0
    
15.     For Each m In [b2:b615].SpecialCells(xlCellTypeVisible)
    
16.         s = s + 1
    
17.         If s < 11 Then
    
18.             h = m.Row
    
19.             n = n + 1
    
20.             brr(n, 1) = Cells(h, 2)
    
21.             brr(n, 2) = Cells(h, 4)
    
22.             brr(n, 3) = Cells(h, 5)
    
23.             brr(n, 4) = Cells(h, "h")
    
24.             brr(n, 5) = Cells(h, "i")
    
25.             brr(n, 9) = Cells(h, "j")
    
26.             brr(n, 10) = Cells(h, "l")
    
27.             brr(n, 11) = Cells(h, "m")
    
28.             If s = 10 Then n = n + 1: brr(n, 1) = w(i) & "  10人 "
    
29.         End If
    
30.     Next
    
31. Next
    
32. ActiveSheet.ShowAllData
    
33. [a1].AutoFilter
    
34. Sheet1.Range("a2").Resize(n, UBound(brr, 2)) = brr
    
35. rng = arr
    
36. MsgBox Timer - t
    
37. Application.ScreenUpdating = True
    
38. End Sub
    

复制代码

张雄友

dsmch 发表于 2014-4-15 20:15
用时0.12s

完成提取后，《明细》中的数据怎么能变回原来的不筛选状态。

张雄友

dsmch 发表于 2014-4-15 20:15
用时0.12s

能否在明细中执行后，然后一键生成《10名高》和《10名低》中的数据。

dsmch

用时0.14s

1. Sub Macro2()
   
2. Dim rng As Range, arr, brr(1 To 20000, 1 To 11), i&, n&, s%
   
3. t = Timer
   
4. Application.ScreenUpdating = False
   
5. Sheets("明细").Activate
   
6. Set rng = [a1:o615]
   
7. arr = rng
   
8. w = Array("3A", "3B", "3C", "2G", "2H", "2J", "A1", "A2", "B1")
   
9. Sheets("明细").FilterMode = False
   
10. rng.Sort Key1:=Range("j2"), Order1:=xlDescending, Header:=xlGuess
    
11. For i = 0 To UBound(w)
    
12.     Range("a1").AutoFilter Field:=2, Criteria1:=w(i)
    
13.     [l1].AutoFilter Field:=12, Criteria1:=">=" & 8
    
14.     GoSub 100
    
15. Next
    
16. ActiveSheet.ShowAllData
    
17. Sheet1.Range("a2").Resize(n, UBound(brr, 2)) = brr
    
18. Erase brr
    
19. n = 0
    
20. rng.Sort Key1:=Range("J2"), Order1:=xlAscending, Header:=xlGuess
    
21. For i = 0 To UBound(w)
    
22.     Range("a1").AutoFilter Field:=2, Criteria1:=w(i)
    
23.     [l1].AutoFilter Field:=12, Criteria1:=">=" & 8
    
24.    GoSub 100
    
25. Next
    
26. ActiveSheet.ShowAllData
    
27. [a1].AutoFilter
    
28. Sheet4.Range("a2").Resize(n, UBound(brr, 2)) = brr
    
29. rng = arr
    
30. MsgBox Timer - t
    
31. GoTo line1
    
32. 100:
    
33. s = 0
    
34. For Each m In [b2:b615].SpecialCells(xlCellTypeVisible)
    
35.     s = s + 1
    
36.     If s < 11 Then
    
37.         h = m.Row
    
38.         n = n + 1
    
39.         brr(n, 1) = Cells(h, 2)
    
40.         brr(n, 2) = Cells(h, 4)
    
41.         brr(n, 3) = Cells(h, 5)
    
42.         brr(n, 4) = Cells(h, "h")
    
43.         brr(n, 5) = Cells(h, "i")
    
44.         brr(n, 9) = Cells(h, "j")
    
45.         brr(n, 10) = Cells(h, "l")
    
46.         brr(n, 11) = Cells(h, "m")
    
47.         If s = 10 Then n = n + 1: brr(n, 1) = w(i) & "  10人 "
    
48.     End If
    
49. Next
    
50. Return
    
51. line1:
    
52. Application.ScreenUpdating = True
    
53. End Sub
    

复制代码

张雄友

dsmch 发表于 2014-4-15 21:00
用时0.14s

当某个车间人数不足10人时，会出错。

张雄友

dsmch 发表于 2014-4-15 21:00
用时0.14s

要这样子。