Excel以数据库SQL的形式查询本表

Function qh_excel_query12(qh_strSQL0, Optional qh_PathStr0 = "") '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

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
    '获取结果数据
    On Error Resume Next
    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)
        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
        .MoveNext
    Loop
    .Close    '关闭数据库连接
End With
qh_Conn.Close
Set qh_RstConn = Nothing
Set qh_RstRst = Nothing
qh_excel_query12 = qh_result_array
End Function

应用

Sub test()
Dim aa As Variant
qh_sheet_name = "买单"
qh_range = "A9"
qh_last_row = Sheets(qh_sheet_name).Range(qh_range).End(xlDown).Row

qh_strSQL = "select 运单号,sum(数量) from [" & qh_sheet_name & "$a9:aj" & qh_last_row & "] where 1 = 1 and 报关类型 = '买单' GROUP BY 运单号"

qh_strSQL = "select 英文品名,sum(数量),sum(箱数),sum(本行实重),sum(本行实重)-sum(箱数),sum(本行方数) from [" & qh_sheet_name & "$a9:aj" & qh_last_row & "] where 1 = 1 GROUP BY 英文品名 "  '清关装箱单

qh_strSQL = "select 英文品名,HS_CODE,单价,sum(数量) as 总数量,单位,单价*sum(数量) as 总价,sum(本行实重)-sum(箱数) as 净重,规范品名,税率 from [" & qh_sheet_name & "$a9:aj" & qh_last_row & "] where 1 = 1 GROUP BY 英文品名,HS_CODE,单价,单位,规范品名,税率 "  '清关装箱单

aa = qh_excel_query12(qh_strSQL)

qh_len = qh_len_arr_duo(Application.Transpose(aa))
qh_len0 = qh_len(0)
qh_len1 = qh_len(1)

Sheets("清关发票").Cells(qh_i + 1, 1).Resize(qh_len1, qh_len0) = Application.Transpose(Application.Transpose(aa))

'For qh_i = 0 To qh_len - 1
'    bb = aa(qh_i)
''     qh_len1 = qh_len_arr(bb)
''    For qh_j = 1 To qh_len1
''        Sheets().Cells
''    Next
'    Sheets("清关发票").Cells(qh_i + 1, 1).Resize(1, 9) = Application.Transpose(Application.Transpose(bb))
'Next


End Sub

支持是否需要标题

Function qh_excel_query12(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
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
    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_query12 = qh_result_array
End Function