Question

我有一个Excel文件供同事从SQL服务器中提取报告。

我们为其部门创建了单独的用户和密码。

我有一个模块，它在Excel文件中显示SQL查询的结果。

这是工作代码：

Sub Button3_Click()

    ActiveSheet.Cells.Clear

    Dim qt As QueryTable

    sqlstring1 = "SELECT * FROM dbo.ReportDataAdded ORDER BY ProductID, CountryCodeID"

    With ActiveSheet.QueryTables.Add(Connection:=getConnectionStr2, Destination:=Range("A3"), Sql:=sqlstring1)

        .Refresh

    End With

End Sub

Private Function getConnectionStr2()
getConnectionStr2 = "ODBC;DRIVER={SQL Server};" & _
                   "DATABASE=em_CountryConsumer;" & _
                   "SERVER=192.192.192.192;" & _
                   "UID=UserName;" & _
                   "PWD=passwordd;"
End Function

我需要将另一个查询的结果填充到组合框中。为此，我需要使用dataset数据类型将查询结果转换为变量。

如何更改我的VBA代码呢？

Answer 1

以下是我过去如何处理类似问题的示例：

这里首先是一个基于给定connection_string和查询来查询数据库的函数。

Function GetQuery(SQL As String, connect_string As String, Optional HasFields As Long = 0) As Variant
    '''
    ' Returns: A Variant() Array with results from query.
    '
    ' HasFields is an optional field to include the field names in the array
    '   Any integer in this field will include fields, leave it blank for just data
    '''
    Dim Conn As New ADODB.Connection
    Dim RS As New ADODB.Recordset
    Dim data_sheet As Worksheet
    Dim R As Long, C As Long
    Dim dbArr() As Variant

    '''''''''''''''''''''''''''''
    ' Setting Up DB connection
    '''''''''''''''''''''''''''''
conReTry:
    On Error GoTo ConnectErr:
    With Conn
        .ConnectionString = connect_string
        .Open
    End With

ConnectErr:
    If Err.Number <> 0 Then
        MsgBox "There was an issue connecting to the Central DB."
        Resume subexit
    End If
    On Error GoTo 0

     ''''''''''''''''''''''
    ' Starting the connection to DB
    ''''''''''''''''''''''
    On Error GoTo QueryErr:
    RS.Open SQL, Conn, adOpenStatic
QueryErr:
    If Err.Number <> 0 Then
        MsgBox "There was a problem with the Query. Could not get results from the statement:" & vbCrLf & Err.Description
        dbArr = Array(" Failed Q ", " Failed Q ")
        Resume subexit
    End If

    On Error GoTo 0
    '''''''''''''''''''''
    ' Parse Data and fill array: DBarr
    '''''''''''''''''''''
    R = 0
    #If VBA7 Then
        Dim tmp_rowNum As LongPtr, tmp_colNum As LongPtr
        Dim rowNum As Integer, colNum As Integer
        tmp_rowNum = RS.RecordCount
        tmp_colNum = RS.Fields.Count
        rowNum = CLng(tmp_rowNum)
        colNum = CLng(tmp_colNum)
    #Else
        Dim rowNum As Long, colNum As Long
        rowNum = RS.RecordCount
        colNum = RS.Fields.Count
    #End If


    If HasFields = 0 Then
        ReDim dbArr(1 To rowNum + 1, 1 To colNum)
    Else
        ReDim dbArr(1 To rowNum + 2, 1 To colNum)
    End If
    Do While Not RS.EOF
        R = R + 1
        For C = 1 To RS.Fields.Count
            If R = 1 And HasFields = 1 Then
                dbArr(R, C) = RS.Fields(C - 1).Name
            ElseIf Not R = 1 Then
                dbArr(R, C) = RS.Fields(C - 1).Value
            End If
        Next
        If Not R = 1 Then RS.MoveNext
    Loop

subexit:
    GetQuery = dbArr
    Set Conn = Nothing
    Set RS = Nothing
End Function

接下来使用Query（A [多维]数组）的结果来设置工作表中的范围：

Sub SetInitData()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim sql_string As String, connect_String as String
    Dim ws as Worksheet
    Set ws = ThisWorkbook.Sheets(config.DATA_SHEET_NAME)

    sql_string = config.GET_INITIAL_PACKTYPE_QUERY
    connect_string = config.MAIN_CONNECTION_STRING

    Debug.Print sql_string

    Dim packtypedata As Variant

    packtypedata = GetQuery(sql_string)

    ws.Range(ws.Cells(1, 1), ws.Cells(UBound(packtypedata), UBound(packtypedata, 2))).Value = packtypedata

    '' Keep Total Rows for next routine explained below
    Dim total_rows as Integer
    total_rows = UBound(packtypedata)
    SetComboBoxValues(total_rows)
    ''' Turn on events and screen updating again
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

最后你要设置ComboBox：

Sub SetComboBoxValues(total_rows As Integer)
    Dim ws as Worksheet, data_ws as Worksheet
    Dim data_arr as Variant
    Dim pack_dd as DropDown

    Set ws = ThisWorkbook.Sheets(config.INPUT_SHEET_NAME)
    Set data_ws = ThisWorkbook.Sheets(config.DATA_SHEET_NAME)
    data_arr = data_ws.Range(data_ws.Cells(1,config.DATA_COL_DROPDOWN_INDEX),
                      data_ws.Cells(total_rows,config.DATA_COL_DROPDOWN_INDEX)).Value

    Set pack_dd = ws.Shapes(config.MAIN_DATA_DROPDOWN_NAME).OLEFormat.Object
    pack_dd.List = pack_dd
    ''' To set the index
    pack_dd.ListIndex = 1
End Sub

**注意 - GetQuery函数有一些我没有时间解决的问题，即我认为包含头文件的HasFields选项实际上不起作用。

我也在使用DropDowns，所以我不确定你是否使用相同类型的对象。

祝你好运

将另一个查询的结果填充到组合框中

1 个答案: