数据库的形式操作excel

最新推荐文章于 2024-06-10 06:55:55 发布

qh0526wy

最新推荐文章于 2024-06-10 06:55:55 发布

阅读量155

点赞数 1

分类专栏： Excel VBA 文章标签： vba

本文链接：https://blog.csdn.net/qh0526wy/article/details/121688470

版权

Excel VBA 专栏收录该内容

17 篇文章 8 订阅

订阅专栏

Function qh_len_arr(qh_array0)    '计算数组的长度  作者:阙辉   2021.02.24
Dim qh_array
Dim qh_array_l

qh_array = qh_array0
qh_array_l = UBound(qh_array) - LBound(qh_array) + 1

qh_len_arr = qh_array_l

End Function
Function qh_excel_query(qh_strSQL0, _
                        Optional qh_PathStr0 = "") 'sql方式查询本表的数据，返回二维数组  作者：阙辉   2021.03.29
'                       qh_strSQL0     Sql查询语句
'                       qh_PathStr0    需要连接的excel表格（路径和表名），如果是本表则为空即可

Dim qh_Conn As Object, qh_Rst As Object
Dim qh_strConn As String, qh_strSQL As String
Dim qh_i As Integer, qh_PathStr As String
Dim qh_result_array
Dim qh_result_array_l As Long
Dim qh_result_array_row
Dim qh_count As Long

qh_strSQL = qh_strSQL0

Set qh_Conn = CreateObject("ADODB.Connection")
Set qh_Rst = CreateObject("ADODB.Recordset")
'设置工作簿的完整路径和名称
If qh_PathStr0 = "" Then
    qh_PathStr = ThisWorkbook.FullName
Else
    qh_PathStr = qh_PathStr0
End If
Select Case Application.Version * 1    '设置连接字符串,根据版本创建连接
Case Is <= 11
    qh_strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & qh_PathStr
Case Is >= 12
    qh_strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & qh_PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
End Select
'用于判断使用的软件是不是WPS，如果是WPS则使用 Oledb.4.0
qh_is_wps = ""
On Error Resume Next    '忽略错误
    qh_is_wps = Application.WorksheetFunction.Find("WPS", Application.Path)
On Error GoTo 0         '解除忽略错误
If qh_is_wps <> "" Then
    qh_strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & qh_PathStr
End If

'设置SQL查询语句
'qh_strSQL = "SELECT * FROM [凭证$]"
qh_Conn.Open qh_strConn                    '打开数据库链接
Set qh_Rst = qh_Conn.Execute(qh_strSQL)    '执行查询，并将结果输出到记录集对象
With qh_Rst
    qh_count = .Fields.Count                 '重置行数组
    ReDim qh_result_array_row(1 To qh_count) '获取标题
    For qh_i = 0 To qh_count - 1             '填写标题
        qh_result_array_row(qh_i + 1) = .Fields(qh_i).Name
    Next qh_i
    ReDim qh_result_array(0 To 0)                '重置结果数组
    qh_result_array(0) = qh_result_array_row
    '获取结果数据
    Do Until .EOF
        ReDim qh_result_array_row(1 To qh_count)
        For qh_i = 0 To qh_count - 1
            qh_result_array_row(qh_i + 1) = .Fields(qh_i).Value
        Next
        qh_result_array_l = qh_len_arr(qh_result_array)
        qh_result_array_l = qh_result_array_l                   '因为数组是从0开始，所以不用加1
        ReDim Preserve qh_result_array(0 To qh_result_array_l)
        qh_result_array(qh_result_array_l) = qh_result_array_row
        On Error Resume Next    '忽略错误
            .MoveNext
        On Error GoTo 0         '解除忽略错误
    Loop
    .Close    '关闭数据库连接
End With
qh_Conn.Close
Set qh_RstConn = Nothing
Set qh_RstRst = Nothing
qh_excel_query = qh_result_array
End Function