|
楼主 |
发表于 2013-1-11 17:24
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
EXCEL中调用SQL语句的自定义函数
本帖最后由 opiona 于 2013-2-4 17:51 编辑
详见附件(Excel+Access)
Excel中的SQL类.rar
(191.12 KB, 下载次数: 915)
2013-02-04更新
使用SQL多了,每次都要声明,写链接,真麻烦
现在写成了自定义函数,直接调,方便不少啊!
将重复使用的代码写成函数,是个好习惯!!!!!
1、获得SQL查询的结果
- '*****************************************************************************************
- '函数名: GET_SQL
- '函数功能: 获得指定SQL的查询结果,修改CN连接字符串,可以连接各种数据库
- '返回值: 返回一个二维数组
- '参数1: StrSQL 字符类型 SQL查询语句
- '参数2: Biaoti 可参数选 是否输出标题,默认带有标题
- '使用方法: Arr = GET_SQL(StrSQL,true)
- ' Arr(0,1) '//数组第一行为标题行,从i=1 开始是数据
- ' Sh2.Range(Sh2.Cells(1, 1).Address, Sh2.Cells(UBound(Arr, 1) + 1, UBound(Arr, 2) + 1).Address) = Arr
- '*****************************************************************************************
- Public Function GET_SQL(StrSQL As String, Optional Biaoti As Boolean = True) As Variant()
- On Error Resume Next ' 改变错误处理的方式。
- Dim CN, RS
- Err.Clear
- Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
- Set RS = CreateObject("adodb.recordset")
- CN.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.Path & "\Info.mdb"
- RS.Open StrSQL, CN, 1, 3
- If Biaoti = True Then
- ReDim arr(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
- For a = 0 To RS.Fields.Count - 1 '//导入标题
- arr(0, a) = RS.Fields(a).Name
- Next
- For i = 0 To RS.RecordCount - 1 '//导入数据
- For a = 0 To RS.Fields.Count - 1
- arr(i + 1, a) = RS.Fields(a).Value
- Next a
- RS.MoveNext
- Next
- Else
- ReDim arr(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
- For i = 0 To RS.RecordCount - 1 '//导入数据
- For a = 0 To RS.Fields.Count - 1
- arr(i, a) = RS.Fields(a).Value
- Next a
- RS.MoveNext
- Next
- End If
- GET_SQL = arr
- CN.Close '//关闭ADO连接
- Set RS = Nothing
- Set CN = Nothing '//释放内存
- End Function
- '*****************************************************************************************
- Sub 查询结果()
- Dim StrSQL As String
- StrSQL = "SELECT TOP 11 * FROM 双色球"
- arr = GET_SQL(StrSQL)
- 'Arr(0,1) '//数组第一行为标题行,从i=1 开始是数据
- Sheet1.Range(Sheet1.Cells(1, 1).Address, Sheet1.Cells(UBound(arr, 1) + 1, UBound(arr, 2) + 1).Address) = arr
- End Sub
复制代码 2、获得查询的个数
- Public Function InfoToAccess(Strsql) As Integer '//执行SQL语句查到数据个数
- On Error Resume Next ' 改变错误处理的方式。
- Dim CN, RS
- Err.Clear
- If Strsql = "" Then InfoToAccess = 0: Exit Function
- Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
- Set RS = CreateObject("adodb.recordset")
- CN.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.Path & "\Info.mdb"
- RS.Open Strsql, CN, 1, 3
- If Err.Number <> 0 Then InfoToAccess = 0 Else InfoToAccess = RS.RecordCount
- CN.Close '//关闭ADO连接
- Set RS = Nothing
- Set CN = Nothing '//释放内存
- End Function
- Sub 查到数据个数()
- Strsql = "SELECT * FROM 双色球"
- MsgBox InfoToAccess(Strsql)
- End Sub
复制代码
3、执行SQL语句,一般为添加、修改删除语句
- Public Function InfoToAccess(StrSQL) As Boolean '//执行SQL语句,一般为添加、修改删除语句
- On Error Resume Next ' 改变错误处理的方式。
- Err.Clear
- If StrSQL = "" Then InfoToAccess = False: Exit Function
- Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
- Set RS = CreateObject("adodb.recordset")
- CN.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.Path & "\Info.mdb"
- CN.Execute (StrSQL)
- If Err.Number <> 0 Then InfoToAccess = False Else InfoToAccess = True
- CN.Close '//关闭ADO连接
- Set RS = Nothing
- Set CN = Nothing '//释放内存
- End Function
- Sub 执行SQL语句()
- StrSQL = "SELECT * FROM 双色球"
- MsgBox InfoToAccess(StrSQL)
- End Sub
复制代码
|
评分
-
2
查看全部评分
-
|