Excel精英培训网

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

[已解决]VBA实现打开数据筛选结果并返回

[复制链接]
发表于 2015-3-3 23:45 | 显示全部楼层 |阅读模式
如一楼所示附件,有一源文件数据,现在想实现单击按钮1,打开一个.xls文件,然后提取指定列标的数字,包含行的数据,放入
打开文件并筛选出值.xlsm的Sheet2。

算法步骤包括:
1,打开一个.xls文件
2,输入筛选列标和筛选值
3.搜索列标所在的列
4,在该列进行筛选出值
5,将值返还程序所在文件指定位置。




源文件如下:

比赛项目         运动员编号        成绩
排球         2021         55
排球         2022         77
排球         2023         33
排球         2024         11
排球         2025         18
排球         2026         37
排球         2027         89
排球         2028         72
排球         2029         59.60714286
羽毛球         2021         61.96428571
羽毛球         2022         64.32142857
羽毛球         2023         66.67857143
羽毛球         2024         69.03571429
羽毛球         2025         71.39285714
网球         2021         73.75
网球         2022         76.10714286
网球         2023         78.46428571
网球         2024         80.82142857
网球         2025         83.17857143

筛选结果如下:(筛选方式为列标为运动员编号,值为2021)

比赛项目         运动员编号        成绩
排球         2021         55
羽毛球         2021         61.96428571
网球         2021         73.75


不知道程序哪里错了,得不到结果,求助
最佳答案
2015-3-4 06:13
  1. Sub Macro1()
  2. Dim arr, brr, i&, s&, bh, j%
  3. ReDim brr(1 To 2000, 1 To 3)
  4. Application.ScreenUpdating = False
  5. [a2:c2000] = ""
  6. With GetObject(ThisWorkbook.Path & "\源文件.xls")
  7.     arr = .Sheets(1).Range("a1").CurrentRegion
  8.     .Close 0
  9. End With
  10. bh = Application.InputBox("请输入运动员编号")
  11. For i = 2 To UBound(arr)
  12.     If Left(arr(i, 2), 4) = bh Then
  13.         s = s + 1
  14.         For j = 1 To UBound(arr, 2)
  15.             brr(s, j) = arr(i, j)
  16.         Next
  17.     End If
  18. Next
  19. If s > 0 Then Range("a2").Resize(s, 3) = brr
  20. Application.ScreenUpdating = True
  21. End Sub
复制代码
 楼主| 发表于 2015-3-3 23:46 | 显示全部楼层
数据源文件程序和所需要的结果,
求解答

打开文件筛选值.rar

30.99 KB, 下载次数: 3

源文件

回复

使用道具 举报

发表于 2015-3-4 06:13 | 显示全部楼层    本楼为最佳答案   
  1. Sub Macro1()
  2. Dim arr, brr, i&, s&, bh, j%
  3. ReDim brr(1 To 2000, 1 To 3)
  4. Application.ScreenUpdating = False
  5. [a2:c2000] = ""
  6. With GetObject(ThisWorkbook.Path & "\源文件.xls")
  7.     arr = .Sheets(1).Range("a1").CurrentRegion
  8.     .Close 0
  9. End With
  10. bh = Application.InputBox("请输入运动员编号")
  11. For i = 2 To UBound(arr)
  12.     If Left(arr(i, 2), 4) = bh Then
  13.         s = s + 1
  14.         For j = 1 To UBound(arr, 2)
  15.             brr(s, j) = arr(i, j)
  16.         Next
  17.     End If
  18. Next
  19. If s > 0 Then Range("a2").Resize(s, 3) = brr
  20. Application.ScreenUpdating = True
  21. End Sub
复制代码
回复

使用道具 举报

发表于 2015-3-4 06:15 | 显示全部楼层
很简单的应用干嘛非得用窗体?
源数据运动员编号,如2021后有一不可见字符

新建文件夹.zip

16.51 KB, 下载次数: 50

回复

使用道具 举报

 楼主| 发表于 2015-3-4 09:40 | 显示全部楼层
dsmch 发表于 2015-3-4 06:13

功能是实现了,但限制了行数,如果数据超出2000行,3列就无法用了
筛选名称限定了运动员编号,要是想筛选比赛项目也无法用。
文件名必须为源文件.xls如果改了名字也无法使用。

多谢帮助!
回复

使用道具 举报

发表于 2015-3-4 11:05 | 显示全部楼层
本帖最后由 dsmch 于 2015-3-4 11:23 编辑

文件名自己在代码中修改,其他功能已修改

新建文件夹.rar

16.05 KB, 下载次数: 2

回复

使用道具 举报

 楼主| 发表于 2015-3-4 13:31 | 显示全部楼层
dsmch 发表于 2015-3-4 11:05
文件名自己在代码中修改,其他功能已修改

问题解决了,算法还不够完美。

点评

醉了,看楼主的点评和附件。  发表于 2015-3-4 14:59
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 16:22 , Processed in 0.850831 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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