VBA-SQL封装查询函数

最新推荐文章于 2023-08-10 15:45:27 发布

qh0526wy

最新推荐文章于 2023-08-10 15:45:27 发布

阅读量241

点赞数

分类专栏： Excel VBA 文章标签：数据库 microsoft sql

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

版权

Excel VBA 专栏收录该内容

15 篇文章 8 订阅

订阅专栏

该VBA函数通过ADODB连接查询Excel文件中的数据，返回二维数组。它首先创建并打开Connection和Recordset对象，然后执行SQL查询。如果文件路径未指定，则默认为当前工作簿。查询结果可以包含标题行，数据存储在动态调整大小的数组中。

摘要由CSDN通过智能技术生成

Function qh_excel_query(qh_strSQL0, Optional qh_PathStr0 = "", Optional qh_file0 = True) 'sql方式查询本表的数据，返回二维数组  作者：阙辉   2021.03.29

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
Dim qh_is_wps
Dim qh_RstConn
Dim qh_RstRst
Dim qh_file

qh_strSQL = qh_strSQL0
qh_file = qh_file0
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

On Error GoTo QH_MyErr
'如果程序执行报错，则跳转至QH_MyErr
    qh_strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & qh_PathStr
    '设置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
        If qh_file Then      '输出结果是否需要标题  true是需要  false不需要
            '重置行数组
            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
            qh_star = 0
        Else
            '重置结果数组
            ReDim qh_result_array(1 To 1)
            qh_star = 1
        End If
        '获取结果数据
        On Error Resume Next
        qh_count_row = 1    'flag
        Do Until .EOF
            '解析行数据
            ReDim qh_result_array_row(1 To qh_count)
            For qh_i = 0 To qh_count - 1
                qh_value = .Fields(qh_i).Value
                If IsNull(qh_value) Then
                    qh_value = ""
                End If
                qh_result_array_row(qh_i + 1) = qh_value
            Next
            qh_result_array_l = qh_len_arr(qh_result_array)
            If qh_star = 1 And qh_count_row = 1 Then
    '           如果qh_star = 1 And qh_count_row = 1则不需要重置结果数组
            Else
                qh_result_array_l = qh_result_array_l + qh_star         '因为数组是从0开始，所以不用加1
                ReDim Preserve qh_result_array(qh_star To qh_result_array_l)
            End If
            qh_result_array(qh_result_array_l) = qh_result_array_row
            qh_count_row = qh_count_row + 1   'flag
            .MoveNext
        Loop
        .Close    '关闭数据库连接
    End With
    qh_Conn.Close
    Set qh_RstConn = Nothing
    Set qh_RstRst = Nothing
    qh_excel_query = qh_result_array
    
    Exit Function
    
QH_MyErr:       '当排柜表有序号时，SQL需要加序号后执行
    qh_strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & qh_PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""

    '设置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
        If qh_file Then      '输出结果是否需要标题  true是需要  false不需要
            '重置行数组
            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
            qh_star = 0
        Else
            '重置结果数组
            ReDim qh_result_array(1 To 1)
            qh_star = 1
        End If
        '获取结果数据
        On Error Resume Next
        qh_count_row = 1    'flag
        Do Until .EOF
            '解析行数据
            ReDim qh_result_array_row(1 To qh_count)
            For qh_i = 0 To qh_count - 1
                qh_value = .Fields(qh_i).Value
                If IsNull(qh_value) Then
                    qh_value = ""
                End If
                qh_result_array_row(qh_i + 1) = qh_value
            Next
            qh_result_array_l = qh_len_arr(qh_result_array)
            If qh_star = 1 And qh_count_row = 1 Then
    '           如果qh_star = 1 And qh_count_row = 1则不需要重置结果数组
            Else
                qh_result_array_l = qh_result_array_l + qh_star         '因为数组是从0开始，所以不用加1
                ReDim Preserve qh_result_array(qh_star To qh_result_array_l)
            End If
            qh_result_array(qh_result_array_l) = qh_result_array_row
            qh_count_row = qh_count_row + 1   'flag
            .MoveNext
        Loop
        .Close    '关闭数据库连接
    End With
    qh_Conn.Close
    Set qh_RstConn = Nothing
    Set qh_RstRst = Nothing
    qh_excel_query = qh_result_array
    
End Function