[原创] 0秒,快速模糊搜索

qq198310 · 发表于 2006-5-16 23:25

以下是引用[I]qee用[/I]在2006-5-16 23:07:48的发言：[BR]如果从30楼所传表情况看,推荐使用ADO更合适.
Sub aTest()
On Error Resume Next
Dim cn As Object, Sql$, sh As Worksheet
Set cn = CreateObject("ADODB.Connection")
cn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Application.ScreenUpdating = False
Sheets("Result").Select
Range("A4:H" & [A65536].End(xlUp).Row + 1).ClearContents
For Each sh In Worksheets
If sh.Name <> "Result" Then
Sql = "select * from [" & sh.Name & "$] where 药名 like '%" & [b1].Text & "%'"
[A65536].End(xlUp).Offset(1, 0).CopyFromRecordset cn.Execute(Sql)
End If
Next sh
Application.ScreenUpdating = False
cn.Close
Set cn = Nothing
End Sub

谢谢您的指导，但现在我要查找的范围并非只是从药名中找，可能根据厂商或者成份等等来搜索，即所谓的全文搜索，就如楼主的搜索一样，只是我要的搜索结果更多点，不知道能不能有更好更快的方法呢？请赐教。

qee用 · 发表于 2006-5-16 23:35

对数据量很大,符合关系数据库特征的表,一般用ADO是最快的.
从你叙述的情况,和楼主不应是一类问题.以前有你类似的情况,有时间再帮你找找.

ldy888 · 发表于 2006-5-17 14:17

以下是引用[I]qee用[/I]在2006-5-16 11:29:34的发言：[BR]看ldy888兄滴贴子，总是让人愉悦滴。
读ldy888兄滴代码，不吃力，但收获却是相当不小滴。
那代码写滴，是相当不错滴。俺给改改，也是相当不错滴。
可是俺上传这个东东，竟用了俺N多倍于改改的时间！

高!!!实在是高!! 妙!!!!真TNND妙!!!哈哈哈.....心领神会心领神会致敬!! 学习!! 以后多指点!!!

ldy888 · 发表于 2006-5-17 14:23

以下是引用[I]geoLu[/I]在2006-5-16 16:29:12的发言：[BR]
VBA中有Bug：
对多工作表操作时，当前查询的工作表中没有符合查找项时会把上一个工作表的查找结果带下来，造成误差
修改如下：
r = "" '这是新增语句
a = [c65536].End(xlUp).Row + 1
If UCase(ch.Name) = "SHEET1" Then GoTo 1
r = ch.Cells.Find(What:=[b2]).Address
If r = "" Then GoTo 1 '这是新增语句
fr = r

geoLu师兄真是细心,试了下果然如此. 谢谢提醒并修改!.以后请多指正.

ldy888 · 发表于 2006-5-17 14:27

以下是引用[I]nawong[/I]在2006-5-16 10:50:46的发言：[BR]
以下是引用[I]ldy888[/I]在2006-5-16 1:57:13的发言：[BR]
以下是引用[I]nawong[/I]在2006-5-15 16:48:35的发言：[BR]
用
Do
.
.
.
Loop While r <> fr
會讓代碼更簡潔
我水平不高.用过,但感觉慢很多,也许是我用的不对. do loop 用的不是太熟,要不请师兄直接改个完整的发上来,我看看是哪用的不对. 不过我发现用excel提供的组合语句,反不如自已用简单语句编一个相同功能的跑得快. 我一般都是分别FOR它个一千几百次,才决定用哪个的.
Do.....Loop方法，共用學習

谢谢nawong师兄! 哈哈哈...这么多人帮我,高兴!!!!

爱歌学习 · 发表于 2006-5-17 14:35

很有意思，我在 qee用的基础上再改进一下：

NMdfaKc0.rar (38.19 KB, 下载次数: 126) ADO全文模糊搜索： Private Sub Worksheet_Change(ByVal Target As Range) Dim cn As Object, Sql$, sh As Worksheet, rowend& Dim RST As New ADODB.Recordset If Target.Address = [b1].Address And Not IsEmpty([b1]) Then Set cn = CreateObject("ADODB.Connection") cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName Range("A4:H" & [a65536].End(xlUp).Row + 1).ClearContents For Each sh In Worksheets If sh.Name <> "Result" Then Sql = "" For i = 1 To sh.[iv1].End(xlToLeft).Column Sql = Sql & "f" & i & " like '%" & [b1].Text & "%' or " Next Sql = Left(Sql, Len(Sql) - 3) Sql = "select * from [" & sh.Name & "$] where " & Sql [a65536].End(xlUp).Offset(1, 0).CopyFromRecordset cn.Execute(Sql) End If Next cn.Close: Set cn = Nothing End If If Target.Address = [g1].Address And Not IsEmpty([g1]) Then Set RST = CreateObject("Adodb.Recordset") Set cn = CreateObject("ADODB.Connection") cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName Sql = "" For i = 1 To [iv3].End(xlToLeft).Column Sql = Sql & "f" & i & " like '%" & [g1].Text & "%' or " Next Sql = Left(Sql, Len(Sql) - 3) rowend = [a65536].End(xlUp).Row Sql = "select * from [Result$a4:h" & rowend & "] where " & Sql RST.Open Sql, cn, adOpenStatic [a4].CopyFromRecordset RST Range("A" & 4 + RST.RecordCount & ":H" & rowend).ClearContents cn.Close: Set cn = Nothing End If End Sub

ldy888 · 发表于 2006-5-17 15:52

qq198310,我没给你解决的问题,爱歌姐姐帮你搞定了.赶紧谢谢人家.

ADO用起来很棒.决定改为己用[em33]

谢谢爱歌分享.[em23][em23][em23]

qq198310 · 发表于 2006-5-18 21:40

爱歌姐姐，太谢谢你了!同时也要感谢楼主和Qee!

qq198310 · 发表于 2006-5-18 22:01

以下是引用[I]爱歌学习[/I]在2006-5-17 14:35:32的发言：[BR]很有意思，我在 qee用的基础上再改进一下： ADO全文模糊搜索： Private Sub Worksheet_Change(ByVal Target As Range) Dim cn As Object, Sql$, sh As Worksheet, rowend& Dim RST As New ADODB.Recordset If Target.Address = [b1].Address And Not IsEmpty([b1]) Then Set cn = CreateObject("ADODB.Connection") cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName Range("A4:H" & [a65536].End(xlUp).Row + 1).ClearContents For Each sh In Worksheets If sh.Name <> "Result" Then Sql = "" For i = 1 To sh.[iv1].End(xlToLeft).Column Sql = Sql & "f" & i & " like '%" & [b1].Text & "%' or " Next Sql = Left(Sql, Len(Sql) - 3) Sql = "select * from [" & sh.Name & "$] where " & Sql [a65536].End(xlUp).Offset(1, 0).CopyFromRecordset cn.Execute(Sql) End If Next cn.Close: Set cn = Nothing End If If Target.Address = [g1].Address And Not IsEmpty([g1]) Then Set RST = CreateObject("Adodb.Recordset") Set cn = CreateObject("ADODB.Connection") cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName Sql = "" For i = 1 To [iv3].End(xlToLeft).Column Sql = Sql & "f" & i & " like '%" & [g1].Text & "%' or " Next Sql = Left(Sql, Len(Sql) - 3) rowend = [a65536].End(xlUp).Row Sql = "select * from [Result$a4:h" & rowend & "] where " & Sql RST.Open Sql, cn, adOpenStatic [a4].CopyFromRecordset RST Range("A" & 4 + RST.RecordCount & ":H" & rowend).ClearContents cn.Close: Set cn = Nothing End If End Sub

非常感谢你的共享，我试了一下，提高了不少效率，但还是有一点不尽完美的地方，就是在结果中筛选的时候我看不出来你写的语句中什么地方不大对，即使条件相同的情况下每次筛选都会减少最后一个行数据，能否修正一下？谢谢！！方便的话把你的程序注释一下好吗?我得好好跟前辈学习学习！这个东西开发好了我这里的工作效率会提高很多。如果每个查询少3秒的话，我们一个星期星期至少要查询10万次，真的很有用处。谢谢啦！！

gwyhm · 发表于 2006-5-19 14:43

提点意见。

如果完整收缩就收索不到，是什么问题呢？是否可以更改？

		自动登录	找回密码
密码			免费注册