Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 7479|回复: 21

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

[复制链接]
发表于 2014-4-12 19:15 | 显示全部楼层 |阅读模式
本帖最后由 张雄友 于 2014-4-17 06:24 编辑

提取每部门提取10名人员,如第10名有多个则提取其中之一即可。
最佳答案
2014-4-17 06:02
  1. Sub Macro2()
  2. Dim rng As Range, arr, brr(1 To 20000, 1 To 11), i&, n&, s%
  3. Application.ScreenUpdating = False
  4. Sheets("明细").Activate
  5. Set rng = [a1:o615]
  6. arr = rng
  7. w = Array("3A", "3B", "3C", "2G", "2H", "2J", "A1", "A2", "B1")
  8. Sheets("明细").FilterMode = False
  9. rng.Sort Key1:=Range("j2"), Order1:=xlDescending, Header:=xlGuess
  10. For i = 0 To UBound(w)
  11.     Range("a1").AutoFilter Field:=2, Criteria1:=w(i)
  12.     [l1].AutoFilter Field:=12, Criteria1:=">=" & 8
  13.     GoSub 100
  14. Next
  15. ActiveSheet.ShowAllData
  16. Sheet1.Range("a2").Resize(n, UBound(brr, 2)) = brr
  17. Erase brr
  18. n = 0
  19. rng.Sort Key1:=Range("J2"), Order1:=xlAscending, Header:=xlGuess
  20. For i = 0 To UBound(w)
  21.     Range("a1").AutoFilter Field:=2, Criteria1:=w(i)
  22.     [l1].AutoFilter Field:=12, Criteria1:=">=" & 8
  23.    GoSub 100
  24. Next
  25. ActiveSheet.ShowAllData
  26. [a1].AutoFilter
  27. Sheet4.Range("a2").Resize(n, UBound(brr, 2)) = brr
  28. rng = arr
  29. GoTo line1
  30. 100:
  31. s = 0
  32. For Each m In [b2:b615].SpecialCells(xlCellTypeVisible)
  33.     s = s + 1
  34.     If s < 11 Then
  35.         h = m.Row
  36.         n = n + 1
  37.         brr(n, 1) = Cells(h, 2)
  38.         brr(n, 2) = Cells(h, 4)
  39.         brr(n, 3) = Cells(h, 5)
  40.         brr(n, 4) = Cells(h, "h")
  41.         brr(n, 5) = Cells(h, "i")
  42.         brr(n, 9) = Cells(h, "j")
  43.         brr(n, 10) = Cells(h, "l")
  44.         brr(n, 11) = Cells(h, "m")
  45.     Else
  46.         Exit For
  47.     End If
  48. Next
  49. y = IIf(s > 10, 1, 11 - s)
  50. y2 = IIf(s > 10, 10, s)
  51. n = n + y: brr(n, 1) = w(i) & "  " & y2 & "人 "
  52. Return
  53. line1:
  54. Application.ScreenUpdating = True
  55. End Sub
复制代码

提取10名最高最低收入优化代码.rar

46.87 KB, 下载次数: 19

 楼主| 发表于 2014-4-12 19:16 | 显示全部楼层
制作通过录制宏完成,当日收入前是插入三列,不是三行,纠正一下。
回复

使用道具 举报

发表于 2014-4-12 20:10 | 显示全部楼层
Sub 生成最低()
Application.ScreenUpdating = False
[A2:K132].ClearContents
提取3A
提取3B
提取3C
提取2G
提取2H
提取2J
提取A1
提取A2
提取B1
插入最低
Application.ScreenUpdating = True
MsgBox "OK,提取完毕"
End Sub
Sub 插入最低()
Application.ScreenUpdating = False
    Columns("F:H").Insert Shift:=xlToRight '当日收入前插入三行
    [A1] = "部门"
    [B1] = "工号"
    [C1] = "组别"
    [D1] = "姓名"
    [E1] = "入厂日期"
    [F1] = "工龄"
    [G1] = "月收入"
    [H1] = "前一天收入"
    [I1] = "当日收入"
    [J1] = "上班小时"
    [K1] = "平均时薪"
    [L1:IV1].ClearContents
Application.ScreenUpdating = True
End Sub
Sub 提取3A()
Application.ScreenUpdating = False
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes';data source=" & ThisWorkbook.FullName
    SQL = "select top 10 车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] where 车间 = '3A' and 上班小时 >= 8  order by 金额-序号/10000 "
    'SQL是设置条件语句,hdr=YES,是默认第一行是标题,有标题的,hdr=NO,是没有设置标题的,字段用F1,F1,F3,F(N)代替。
    Range("A2").CopyFromRecordset conn.Execute(SQL)
    Range("A12") = "3A 10人"
    Set conn = Nothing
Application.ScreenUpdating = True
'MsgBox "OK,提取完毕"
End Sub
Sub 提取3B()
Application.ScreenUpdating = False
'[A2:O65536].ClearContents
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes';data source=" & ThisWorkbook.FullName
    SQL = "select top 10 车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] where 车间 = '3B' and 上班小时 >= 8  order by 金额-序号/10000 "
    'SQL是设置条件语句,hdr=YES,是默认第一行是标题,有标题的,hdr=NO,是没有设置标题的,字段用F1,F1,F3,F(N)代替。
    Range("A13").CopyFromRecordset conn.Execute(SQL)
    Range("A23") = "3B 10人"
    Set conn = Nothing
Application.ScreenUpdating = True
'MsgBox "OK,提取完毕"
End Sub
Sub 提取3C()
Application.ScreenUpdating = False
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes';data source=" & ThisWorkbook.FullName
    SQL = "select top 10 车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] where 车间 = '3C' and 上班小时 >= 8  order by 金额-序号/10000 "
    'SQL是设置条件语句,hdr=YES,是默认第一行是标题,有标题的,hdr=NO,是没有设置标题的,字段用F1,F1,F3,F(N)代替。
    Range("A24").CopyFromRecordset conn.Execute(SQL)
    Range("A34") = "3C 10人"
    Set conn = Nothing
Application.ScreenUpdating = True
'MsgBox "OK,提取完毕"
End Sub

Sub 提取2G()
Application.ScreenUpdating = False
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes';data source=" & ThisWorkbook.FullName
    SQL = "select top 10 车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] where 车间 = '2G' and 上班小时 >= 8  order by 金额-序号/10000 "
    'SQL是设置条件语句,hdr=YES,是默认第一行是标题,有标题的,hdr=NO,是没有设置标题的,字段用F1,F1,F3,F(N)代替。
    Range("A35").CopyFromRecordset conn.Execute(SQL)
    Range("A45") = "2G 10人"
    Set conn = Nothing
Application.ScreenUpdating = True
'MsgBox "OK,提取完毕"
End Sub
Sub 提取2H()
Application.ScreenUpdating = False
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes';data source=" & ThisWorkbook.FullName
    SQL = "select top 10 车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] where 车间 = '2H' and 上班小时 >= 8  order by 金额-序号/10000 "
    'SQL是设置条件语句,hdr=YES,是默认第一行是标题,有标题的,hdr=NO,是没有设置标题的,字段用F1,F1,F3,F(N)代替。
    Range("A46").CopyFromRecordset conn.Execute(SQL)
    Range("A56") = "2H 10人"
    Set conn = Nothing
Application.ScreenUpdating = True
'MsgBox "OK,提取完毕"
End Sub
Sub 提取2J()
Application.ScreenUpdating = False
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes';data source=" & ThisWorkbook.FullName
    SQL = "select top 10 车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] where 车间 = '2J' and 上班小时 >= 8  order by 金额-序号/10000 "
    'SQL是设置条件语句,hdr=YES,是默认第一行是标题,有标题的,hdr=NO,是没有设置标题的,字段用F1,F1,F3,F(N)代替。
    Range("A57").CopyFromRecordset conn.Execute(SQL)
    Range("A67") = "2J 10人"
    Set conn = Nothing
Application.ScreenUpdating = True
'MsgBox "OK,提取完毕"
End Sub


提取,提取,提取,.......要是还有十多个,不累死才怪,这十多个提取都可以并做一个,一次性完成,代码确实多,方法:为每个部门所有人员给定一个排序号,限定提取前10名就成,十多个模块只用一个模块就可以达到要求的
  SQL = "select top 10 车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] where 车间 = '2H' and 上班小时 >= 8  o  想帮你,但怕你反感我,只好提个醒

回复

使用道具 举报

 楼主| 发表于 2014-4-12 20:12 | 显示全部楼层
本帖最后由 张雄友 于 2014-4-12 20:14 编辑
xpw6061 发表于 2014-4-12 20:10
Sub 生成最低()
Application.ScreenUpdating = False
[A2:K132].ClearContents

请不惜赐教。

附件有更新。
回复

使用道具 举报

发表于 2014-4-12 20:38 | 显示全部楼层
张雄友 发表于 2014-4-12 20:12
请不惜赐教。

附件有更新。

    SQL = "select  车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] a  where  上班小时 >= 8 and (select count(*) from  [明细$] where 金额>=a.金额 and 车间=a.车间)<=10 order by 车间, 金额  desc"

把上面的这句加上去,新建一个表看看实际效果,其它的代码不用写了,反正都一样,执行一下,看能不能取代那十多个提取,速度可能有点慢,我没测试,随手写的,有问题别怪,每个车间后面的"10人"就没法写了,另建模块再进行二次操作
回复

使用道具 举报

 楼主| 发表于 2014-4-12 20:49 | 显示全部楼层
xpw6061 发表于 2014-4-12 20:38
SQL = "select  车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] a  where  上班 ...

测试后发现3B车间少了一条记录。
回复

使用道具 举报

发表于 2014-4-12 21:19 | 显示全部楼层
张雄友 发表于 2014-4-12 20:49
测试后发现3B车间少了一条记录。

把数据里有关3B的金额最大的前10条记录删除试试,记住是整行删除,有可能有非法数据在里面
回复

使用道具 举报

发表于 2014-4-12 21:36 | 显示全部楼层
张雄友 发表于 2014-4-12 20:49
测试后发现3B车间少了一条记录。

这条记录上班时间小于8小时吧,没选 上吧
2.jpg
回复

使用道具 举报

 楼主| 发表于 2014-4-12 21:40 | 显示全部楼层
xpw6061 发表于 2014-4-12 21:36
这条记录上班时间小于8小时吧,没选 上吧

不是的,有足够数据可供选择。
回复

使用道具 举报

发表于 2014-4-13 10:27 | 显示全部楼层
张雄友 发表于 2014-4-12 21:40
不是的,有足够数据可供选择。

理解错误,这句是正确的了,上班时间小于8的,排除在外,另选10人最高的


SQL = "select  车间,工号,组别,姓名,入厂日期,金额,上班小时,平均时薪 from [明细$] a  where  (select count(*) from  [明细$] where iif(上班小时>=8,金额,0)>=iif(a.上班小时>=8,a.金额,0) and 车间=a.车间)<=10 order by 车间, 金额  desc"

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 19:45 , Processed in 0.662112 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表