Populate result of another query into combo box - sql

Question

I have an Excel file for colleagues to extract reports from SQL server.
We created separate user and password for their department.
I have the module which shows the result of SQL query in an Excel file.
Here is working code:
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
I need to populate the result of another query into combo box. For that I need to get result of query into variable with dataset datatype.
How can I change my VBA code to do that?

Answer 1

Here is an example of how I have handled a similar problem in the past:
First here is a function to Query the database based with a given connection_string and query.
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
Next use the result of the Query (A [multi-dimensional] Array) to set the range in a worksheet:
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
Finally you want to set the 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
** Note -- The GetQuery function has some kinks that I haven't had time to work out, namely I don't think the HasFields option to include headers actually works.
Also I'm using DropDowns, so I'm not sure if you are using the same type of object.
Good Luck