设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › VBA按条件查询名单
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2036|回复: 4

[已解决]VBA按条件查询名单

[复制链接]
发表于 2016-6-29 10:14 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 龙送农 于 2016-6-29 13:17 编辑

VBA调年龄或工龄名单：
1、年龄段名单：条件1是单元格F2（单位），条件2是岁段单元格M2至O2。
2、工龄段名单：条件1是单元格F2（单位），条件2是岁段单元格V2至X2。
分别选择或录入上述单元格信息后，自动调出本表名单信息。

最佳答案
月排行榜 / 总排行榜
老司机带带我
2016-6-29 12:57
代码自己替换下！
  1. Dim y%
  2. Sub 按工龄()
  3.     y = 17
  4.     If [V2] = "" Or [X2] = "" Then Exit Sub
  5.     Call xx([V2], [X2])
  6. End Sub
  7. Sub 按年龄()
  8.     y = 15
  9.     If [M2] = "" Or [O2] = "" Then Exit Sub
  10.     Call xx([M2], [O2])
  11. End Sub

  13. Sub xx(u As Integer, v As Integer)
  14.     Dim arr, i&, j&, n&, k&
  15.     n = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
  16.     arr = Sheet1.Range("A5:BG" & n)
  17.     Application.ScreenUpdating = False
  18.     k = 4
  19.     With Sheet3
  20.         .Range("a5:ag5000").Delete
  21.         For i = 1 To n - 4
  22.             If .[f2] = "全部" Then
  23.                 If arr(i, y) >= u And arr(i, y) <= v Then
  24.                     k = k + 1
  25.                     .Cells(k, 1) = k - 4
  26.                     .Cells(k, 2) = arr(i, 3)
  27.                     .Cells(k, 3) = arr(i, 8)   '机构，自己修改
  28.                     .Cells(k, 4) = arr(i, 5)
  29.                     .Cells(k, 5) = arr(i, 6)
  30.                     .Cells(k, 6) = arr(i, 7)
  31.                     For j = 7 To 10
  32.                         .Cells(k, j) = arr(i, j + 2)
  33.                     Next
  34.                     For j = 11 To 24
  35.                         .Cells(k, j) = arr(i, j + 3)
  36.                     Next
  37.                     For j = 25 To 32
  38.                         .Cells(k, j) = arr(i, j + 6)
  39.                     Next
  40.                     .Cells(k, 33) = arr(i, 59)
  41.                 End If
  42.             Else
  43.                 If arr(i, y) >= u And arr(i, y) <= v And arr(i, 4) = .[f2] Then
  44.                     k = k + 1
  45.                     .Cells(k, 1) = k - 4
  46.                     .Cells(k, 2) = arr(i, 3)
  47.                     .Cells(k, 3) = arr(i, 8)   '机构，自己修改
  48.                     .Cells(k, 4) = arr(i, 5)
  49.                     .Cells(k, 5) = arr(i, 6)
  50.                     .Cells(k, 6) = arr(i, 7)
  51.                     For j = 7 To 10
  52.                         .Cells(k, j) = arr(i, j + 2)
  53.                     Next
  54.                     For j = 11 To 24
  55.                         .Cells(k, j) = arr(i, j + 3)
  56.                     Next
  57.                     For j = 25 To 32
  58.                         .Cells(k, j) = arr(i, j + 6)
  59.                     Next
  60.                     .Cells(k, 33) = arr(i, 59)
  61.                 End If
  62.             End If
  63.         
  64.         Next
  65.     End With
  66.     Application.ScreenUpdating = True
  67. End Sub
复制代码

VBA按条件查询名单.rar

13.78 KB, 下载次数: 19
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2016-6-29 10:53 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
所在机构名称对应数据库的哪一项?
回复

使用道具 举报

发表于 2016-6-29 11:35 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Dim y%
  2. Sub 按工龄()
  3.     y = 17
  4.     If [V2] = "" Or [X2] = "" Then Exit Sub
  5.     Call xx([V2], [X2])
  6. End Sub
  7. Sub 按年龄()
  8.     y = 15
  9.     If [M2] = "" Or [O2] = "" Then Exit Sub
  10.     Call xx([M2], [O2])
  11. End Sub

  13. Sub xx(u As Integer, v As Integer)
  14.     Dim arr, i&, j&, n&, k&
  15.     n = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
  16.     arr = Sheet1.Range("A5:BG" & n)
  17.     Application.ScreenUpdating = False
  18.     k = 4
  19.     With Sheet3
  20.         .Range("a5:ag5000").Delete
  21.         For i = 1 To n - 4
  22.             If .[f2] = "全部" Then
  23.                 If arr(i, y) >= u And arr(i, y) <= v Then
  24.                     k = k + 1
  25.                     .Cells(k, 1) = arr(i, 1)
  26.                     .Cells(k, 2) = arr(i, 3)
  27.                     .Cells(k, 3) = arr(i, 8)   '机构，自己修改
  28.                     .Cells(k, 4) = arr(i, 5)
  29.                     .Cells(k, 5) = arr(i, 6)
  30.                     .Cells(k, 6) = arr(i, 7)
  31.                     For j = 7 To 10
  32.                         .Cells(k, j) = arr(i, j + 2)
  33.                     Next
  34.                     For j = 11 To 24
  35.                         .Cells(k, j) = arr(i, j + 3)
  36.                     Next
  37.                     For j = 25 To 32
  38.                         .Cells(k, j) = arr(i, j + 6)
  39.                     Next
  40.                     .Cells(k, 33) = arr(i, 59)
  41.                 End If
  42.             Else
  43.                 If arr(i, y) >= u And arr(i, y) <= v And arr(i, 4) = .[f2] Then
  44.                     k = k + 1
  45.                     .Cells(k, 1) = arr(i, 1)
  46.                     .Cells(k, 2) = arr(i, 3)
  47.                     .Cells(k, 3) = arr(i, 8)   '机构，自己修改
  48.                     .Cells(k, 4) = arr(i, 5)
  49.                     .Cells(k, 5) = arr(i, 6)
  50.                     .Cells(k, 6) = arr(i, 7)
  51.                     For j = 7 To 10
  52.                         .Cells(k, j) = arr(i, j + 2)
  53.                     Next
  54.                     For j = 11 To 24
  55.                         .Cells(k, j) = arr(i, j + 3)
  56.                     Next
  57.                     For j = 25 To 32
  58.                         .Cells(k, j) = arr(i, j + 6)
  59.                     Next
  60.                     .Cells(k, 33) = arr(i, 59)
  61.                 End If
  62.             End If
  63.         
  64.         Next
  65.     End With
  66.     Application.ScreenUpdating = True
  67. End Sub
复制代码

VBA按条件查询名单.rar

11.55 KB, 下载次数: 36
回复

使用道具 举报

 楼主| 发表于 2016-6-29 12:42 | 显示全部楼层
老司机带带我 发表于 2016-6-29 11:35

老师：麻烦加个“序号”自动
回复

使用道具 举报

发表于 2016-6-29 12:57 | 显示全部楼层    本楼为最佳答案   
代码自己替换下！
  1. Dim y%
  2. Sub 按工龄()
  3.     y = 17
  4.     If [V2] = "" Or [X2] = "" Then Exit Sub
  5.     Call xx([V2], [X2])
  6. End Sub
  7. Sub 按年龄()
  8.     y = 15
  9.     If [M2] = "" Or [O2] = "" Then Exit Sub
  10.     Call xx([M2], [O2])
  11. End Sub

  13. Sub xx(u As Integer, v As Integer)
  14.     Dim arr, i&, j&, n&, k&
  15.     n = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
  16.     arr = Sheet1.Range("A5:BG" & n)
  17.     Application.ScreenUpdating = False
  18.     k = 4
  19.     With Sheet3
  20.         .Range("a5:ag5000").Delete
  21.         For i = 1 To n - 4
  22.             If .[f2] = "全部" Then
  23.                 If arr(i, y) >= u And arr(i, y) <= v Then
  24.                     k = k + 1
  25.                     .Cells(k, 1) = k - 4
  26.                     .Cells(k, 2) = arr(i, 3)
  27.                     .Cells(k, 3) = arr(i, 8)   '机构，自己修改
  28.                     .Cells(k, 4) = arr(i, 5)
  29.                     .Cells(k, 5) = arr(i, 6)
  30.                     .Cells(k, 6) = arr(i, 7)
  31.                     For j = 7 To 10
  32.                         .Cells(k, j) = arr(i, j + 2)
  33.                     Next
  34.                     For j = 11 To 24
  35.                         .Cells(k, j) = arr(i, j + 3)
  36.                     Next
  37.                     For j = 25 To 32
  38.                         .Cells(k, j) = arr(i, j + 6)
  39.                     Next
  40.                     .Cells(k, 33) = arr(i, 59)
  41.                 End If
  42.             Else
  43.                 If arr(i, y) >= u And arr(i, y) <= v And arr(i, 4) = .[f2] Then
  44.                     k = k + 1
  45.                     .Cells(k, 1) = k - 4
  46.                     .Cells(k, 2) = arr(i, 3)
  47.                     .Cells(k, 3) = arr(i, 8)   '机构，自己修改
  48.                     .Cells(k, 4) = arr(i, 5)
  49.                     .Cells(k, 5) = arr(i, 6)
  50.                     .Cells(k, 6) = arr(i, 7)
  51.                     For j = 7 To 10
  52.                         .Cells(k, j) = arr(i, j + 2)
  53.                     Next
  54.                     For j = 11 To 24
  55.                         .Cells(k, j) = arr(i, j + 3)
  56.                     Next
  57.                     For j = 25 To 32
  58.                         .Cells(k, j) = arr(i, j + 6)
  59.                     Next
  60.                     .Cells(k, 33) = arr(i, 59)
  61.                 End If
  62.             End If
  63.         
  64.         Next
  65.     End With
  66.     Application.ScreenUpdating = True
  67. End Sub
复制代码
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-26 17:31 , Processed in 0.165514 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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