速查●成语词典

39660519

学良 发表于 2022-1-23 10:34
感谢 27 楼 39660519 老师提供的资料!

我用SQL做的多条件查询。

前进者

感谢各位大神老师的分享！

前进者

39660519 发表于 2022-9-30 15:22
我用SQL做的多条件查询。

大神好！我下载后提示宏被禁用，启用宏后还不能运行，请指教！谢谢

前进者

39660519

前进者 发表于 2022-10-3 11:41

我用的几台电脑都没有问题，你换台电脑试试，可能是你的设置问题，具体我也不清楚，你去信任中心看看

前进者

39660519 发表于 2022-10-3 15:55
我用的几台电脑都没有问题，你换台电脑试试，可能是你的设置问题，具体我也不清楚，你去信任中心看看

信任中心已设置过，自己编制的宏都可以用！下载的这个却不能用！

39660519

前进者 发表于 2022-10-3 16:13
信任中心已设置过，自己编制的宏都可以用！下载的这个却不能用！

我另存为03版本，你试试，要不你自己复制代码写进去

1. Function 去掉重复字节(内容, 字节)
   
2.     Dim 正则对象 As Object
   
3.     Dim 匹配值集合 As Object, 匹配值 As Object
   
4.     Set 正则对象 = CreateObject("VBSCRIPT.REGEXP")
   
5.     With 正则对象
   
6.         .Global = True
   
7.         .MultiLine = True
   
8.         .IgnoreCase = True
   
9.         .Pattern = 字节 & "+"
   
10.         去掉重复字节 = .Replace(内容, 字节)
    
11.     End With
    
12. End Function
    
13. 
    
14. Function 查询语句开头()
    
15.     With Sheets("数据存储")
    
16.         For A = 1 To 12
    
17.             If A = 1 Then
    
18.                 查询语句开头 = .Cells(1, A).Value
    
19.             Else
    
20.                 查询语句开头 = 查询语句开头 & "," & .Cells(1, A).Value
    
21.             End If
    
22.         Next A
    
23.         查询语句开头 = "Select " & 查询语句开头 & " from [数据存储$] where "
    
24.     End With
    
25. End Function
    
26. 
    
27. Function 成语查询语句条件()
    
28.     With Sheets("查询条件")
    
29.         包含内容 = .Cells(3, "B").Value
    
30.         If 包含内容 = "" Then
    
31.             包含内容 = "%"
    
32.         Else
    
33.             包含内容 = "%" & 包含内容 & "%"
    
34.         End If
    
35.         包含某一个字 = .Cells(4, "B").Value
    
36.         If 包含某一个字 = "" Then
    
37.             包含某一个字 = "%"
    
38.         Else
    
39.             包含某一个字 = "%[" & 包含某一个字 & "]%"
    
40.         End If
    
41.         从首字开始 = .Cells(5, "B").Value
    
42.         If 从首字开始 = "" Then
    
43.             从首字开始 = "%"
    
44.         Else
    
45.             从首字开始 = 从首字开始 & "%"
    
46.         End If
    
47.         从尾字开始 = .Cells(6, "B").Value
    
48.         If 从尾字开始 = "" Then
    
49.             从尾字开始 = "%"
    
50.         Else
    
51.             从尾字开始 = "%" & 从尾字开始
    
52.         End If
    
53.         成语查询语句条件 = "成语 like '" & 去掉重复字节(从首字开始 & 包含内容 & 包含某一个字 & 从尾字开始, "%") & "'"
    
54.     End With
    
55. End Function
    
56. 
    
57. Function 四字结构查询语句条件()
    
58.     With Sheets("查询条件")
    
59.         位置1 = .Cells(3, "F").Value
    
60.         If 位置1 = "" Then 位置1 = "_"
    
61.         
    
62.         位置2 = .Cells(4, "F").Value
    
63.         If 位置2 = "" Then 位置2 = "_"
    
64.         
    
65.         位置3 = .Cells(5, "F").Value
    
66.         If 位置3 = "" Then 位置3 = "_"
    
67.         
    
68.         位置4 = .Cells(6, "F").Value
    
69.         If 位置4 = "" Then 位置4 = "_"
    
70.         
    
71.         内容合并 = 位置1 & 位置2 & 位置3 & 位置4
    
72.         
    
73.         四字结构查询语句条件 = " AND 四字结构 like '" & 内容合并 & "'"
    
74.         If 内容合并 = "____" Then 四字结构查询语句条件 = ""
    
75.     End With
    
76. End Function
    
77. 
    
78. Sub 成语查询()
    
79.     Set Conn = CreateObject("ADODB.Connection") '后期绑定
    
80.     Set Rst = CreateObject("ADODB.Recordset")
    
81.     Path = ThisWorkbook.FullName
    
82.     If Application.Version * 1 <= 11 Then '03版以后 Ace的区别
    
83.         strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & Path
    
84.     Else
    
85.         strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Path & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
86.     End If
    
87.     Conn.Open strConn '打开数据库链接
    
88.     StrSQL = 查询语句开头 & 成语查询语句条件 & 四字结构查询语句条件
    
89.     Set Rst = Conn.Execute(StrSQL)
    
90.     Application.ScreenUpdating = False
    
91.     With Sheets("查询结果")
    
92.         .Cells.Clear
    
93.         For i = 0 To Rst.Fields.Count - 1  '填写标题
    
94.             .Cells(1, i + 1) = Rst.Fields(i).Name
    
95.         Next i
    
96.         .Range("A2").CopyFromRecordset Rst
    
97.         '.Cells.EntireColumn.AutoFit '自动调整列宽
    
98.         '.Cells.EntireColumn.AutoFit '自动调整列宽
    
99.     End With
    
100.     Application.ScreenUpdating = True
     
101.     Rst.Close '关闭数据库连接
     
102.     Conn.Close
     
103.     Set Conn = Nothing
     
104.     Set Rst = Nothing
     
105.     Sheets("查询结果").Select
     
106. End Sub
     

复制代码

前进者

谢谢大神，原因我找到了，不是版本问题！

rakehell78

谢谢分享...

taotaole1999

谢谢分享！