Excel精英培训网

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

[已解决]定位筛选代码求优化提速

[复制链接]
发表于 2015-1-12 15:10 | 显示全部楼层 |阅读模式
本帖最后由 zhouxingyu 于 2015-1-14 14:56 编辑

有请哪位老师帮忙,将附件中的代码给优化提速一下,说明详见附件.十分感谢!
(表中数据仅作TEST,不用考虑正确与否)
定位筛选.zip (761.58 KB, 下载次数: 26)
发表于 2015-1-12 15:45 | 显示全部楼层
其实用高级筛选就行,在sheet2上插入一个列名A

模糊值筛选.zip (15.84 KB, 下载次数: 8)
回复

使用道具 举报

 楼主| 发表于 2015-1-12 15:58 | 显示全部楼层
芐雨 发表于 2015-1-12 15:45
其实用高级筛选就行,在sheet2上插入一个列名A

怎么筛选出来的只有A列,B和C列消失?无论如何都谢谢.
回复

使用道具 举报

发表于 2015-1-12 16:05 | 显示全部楼层
不会啊,ABC列都有啊

1.gif
回复

使用道具 举报

 楼主| 发表于 2015-1-12 16:13 | 显示全部楼层
芐雨 发表于 2015-1-12 16:05
不会啊,ABC列都有啊

真奇了怪,我把sheet3的数据先清除,再点击按妞,它就只产生A列一列.
回复

使用道具 举报

发表于 2015-1-12 16:45 | 显示全部楼层
可能是版本不一样,修改了一下范围。
先把sheet2第一行加入所有的列名ABC
模糊值筛选.zip (15.11 KB, 下载次数: 7)

评分

参与人数 1 +2 收起 理由
zhouxingyu + 2 感谢帮助

查看全部评分

回复

使用道具 举报

发表于 2015-1-14 15:45 | 显示全部楼层
有问题不要发消息,直接在楼层回复就可以了,更新也不在第一层更新。
要保留格式,用高级筛选就好,原理不明白可以先了解excel的高级筛选功能,代码就是修改单元格范围就可以了
定位筛选.zip (780.36 KB, 下载次数: 3)

评分

参与人数 1 +2 收起 理由
zhouxingyu + 2 感谢帮助!

查看全部评分

回复

使用道具 举报

发表于 2015-1-14 16:27 | 显示全部楼层
  1. Sub tt()
  2.     Dim CopyRng As Range
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = Sheets("Sheet2").[a1].CurrentRegion
  5.     For i = 1 To UBound(arr)
  6.         d(arr(i, 1)) = ""
  7.     Next
  8.     With Sheets("TEST")
  9.         brr = .[a1].CurrentRegion
  10.         Set CopyRng = .[a1].Resize(1, 21)
  11.         For i = 2 To UBound(brr)
  12.             If d.exists(brr(i, 20)) Then Set CopyRng = Union(CopyRng, .Cells(i, 1).Resize(1, 21))
  13.         Next
  14.     End With
  15.     With Sheets("Sheet3")
  16.         .Cells.Clear
  17.         CopyRng.Copy .[a1]
  18.         .Activate
  19.     End With
  20. End Sub
复制代码

评分

参与人数 1 +3 收起 理由
zhouxingyu + 3 很给力!

查看全部评分

回复

使用道具 举报

发表于 2015-1-14 16:40 | 显示全部楼层    本楼为最佳答案   
如果要体现筛选效果(输出结果按Sheet2里的A列排序),可以这样:
  1. Sub tt()
  2.     Dim CopyRng As Range
  3.     Set d = CreateObject("scripting.dictionary")
  4.     With Sheets("TEST")
  5.         brr = .[a1].CurrentRegion
  6.         Set CopyRng = .[a1].Resize(1, 21)
  7.         For i = 2 To UBound(brr)
  8.             If Not d.exists(brr(i, 20)) Then
  9.                 Set d(brr(i, 20)) = .Cells(i, 1).Resize(1, 21)
  10.             Else
  11.                 Set d(brr(i, 20)) = Union(d(brr(i, 20)), .Cells(i, 1).Resize(1, 21))
  12.             End If
  13.         Next
  14.     End With
  15.    
  16.     arr = Sheets("Sheet2").[a1].CurrentRegion
  17.     For i = 1 To UBound(arr)
  18.         Set CopyRng = Union(CopyRng, d(arr(i, 1)))
  19.     Next
  20.     With Sheets("Sheet3")
  21.         .Cells.Clear
  22.         CopyRng.Copy .[a1]
  23.         .Activate
  24.     End With
  25. End Sub
复制代码

评分

参与人数 1 +3 收起 理由
zhouxingyu + 3 赞一个!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-1-14 16:47 | 显示全部楼层
芐雨 发表于 2015-1-14 15:45
有问题不要发消息,直接在楼层回复就可以了,更新也不在第一层更新。
要保留格式,用高级筛选就好,原理不 ...

发消息是对你消息的回复,其它的下次注意.
你的代码离我想要的稍还有点出入.无论如何都谢谢你了!
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-28 21:43 , Processed in 0.368533 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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