Issue with Multiple selection in listbox as a criteria to extract data from sql server to excel.

[abhay_547]

Hi All,

I have the below macro which I have recorded for importing the data from SQL Server table. I have a userform in which I have list box I am populating that listbox with some values from another sql server table. Now what I am doing is, while importing the data from sql table I select a criteria now I want the user to select multiple items in listbox and my below macro should consider that selection and extract the data accordingly. As of now below mentioned code works fine with single selection in listbox but when I select multiple items in my listbox. It shows error. Please help.

Sub sqldataextract()
Dim Product As String
Dim CostElement As String
CostElement = frmwarehouse.TextBox1.Value
[B]Product = frmwarehouse.ListBox4.Value[/B]
    With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
        "ODBC;DRIVER=SQL Native Client;SERVER=XXXXXXXXX;UID=admin;PWD=*****;APP=Microsoft Office XP;WSID=XXXXXXXX" _
        ), Array(";DATABASE=meta_data;")), Destination:=Range("A1"))
        .CommandText = Array( _
        "SELECT mydata.CAC, mydata.Year, mydata.""Cost Element"", mydata.""Cost Element Name"", mydata.Name, mydata.""Cost Center"", mydata.""Company Code"", mydata.""Unique Indentifier 1"", ""Cost Center mapping"".""Produ" _
        , _
        "ct UBR Code"", ""Cost Element Mapping"".FSI_LINE2_code" & Chr(13) & "" & Chr(10) & "FROM sap_data.dbo.""Cost Center mapping"" ""Cost Center mapping"", sap_data.dbo.""Cost Element Mapping"" ""Cost Element Mapping"", sap_data.dbo.mydata myda" _
        , _
        "ta" & Chr(13) & "" & Chr(10) & "WHERE mydata.""Unique Indentifier 1"" = ""Cost Element Mapping"".CE_SR_NO AND mydata.""Cost Center"" = ""Cost Center mapping"".""Cost Center"" AND ((""Cost Center mapping"".[B]""Product UBR Code""='" & Product & "'[/B]) AND (""" _
        , "Cost Element Mapping"".FSI_LINE2_code='" & CostElement & "'))")
        .Name = "Query from mydatanew"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

Currently my listbox's MultiSelect property is set to 0. If I set it to 1 or 2 the above macro doesn't work.

Please have a look at the attached screenshot. This will help you to understand my issue in better way.

Thanks for your help in advance.

 

[abhay_547]

Hi All,

I got the below link as well which can also be helpful.

http://itknowledgeexchange.techtarget.com/beyond-excel/searching-for-codes/



Thanks a lot for your help in advance.

 

[abhay_547]

Hi All,

I also got the below code from google search which I think can be useful. Please help..

'------------------ Code Start ------------------

Private Sub cmdOpenQuery_Click()

    On Error GoTo Err_cmdOpenQuery_Click
    Dim MyDB As DAO.Database
    Dim qdef As DAO.QueryDef
    Dim i As Integer
    Dim strSQL As String
    Dim strWhere As String
    Dim strIN As String
    Dim flgSelectAll As Boolean
    Dim varItem As Variant

    Set MyDB = CurrentDb()

    strSQL = "SELECT * FROM tblCompanies"

    'Build the IN string by looping through the listbox
    For i = 0 To lstCounties.ListCount - 1
        If lstCounties.Selected(i) Then
            If lstCounties.Column(0, i) = "All" Then
                flgSelectAll = True
            End If
            strIN = strIN & "'" & lstCounties.Column(0, i) & "',"
        End If
    Next i

    'Create the WHERE string, and strip off the last comma of the IN string
    strWhere = " WHERE [strCompanyCounty] in " & _
               "(" & Left(strIN, Len(strIN) - 1) & ")"

    'If "All" was selected in the listbox, don't add the WHERE condition
    If Not flgSelectAll Then
        strSQL = strSQL & strWhere
    End If

    MyDB.QueryDefs.Delete "qryCompanyCounties"
    Set qdef = MyDB.CreateQueryDef("qryCompanyCounties", strSQL)

    'Open the query, built using the IN clause to set the criteria
    DoCmd.OpenQuery "qryCompanyCounties", acViewNormal

    'Clear listbox selection after running query
    For Each varItem In Me.lstCounties.ItemsSelected
        Me.lstCounties.Selected(varItem) = False
    Next varItem


Exit_cmdOpenQuery_Click:
    Exit Sub

Err_cmdOpenQuery_Click:

    If Err.Number = 5 Then
        MsgBox "You must make a selection(s) from the list" _
               , , "Selection Required !"
        Resume Exit_cmdOpenQuery_Click
    Else
        'Write out the error and exit the sub
        MsgBox Err.Description
        Resume Exit_cmdOpenQuery_Click
    End If

End Sub

'------------------ Code End -------------------</pre>

Thanks a lot for your help in advance.

 

[abhay_547]

Hi All,

Finally I got the below code through the extensive google search which I think can be used with SQL. I just need your help it to replicate in my main macro

Sub selectList()

    ' Setup connection string
    Dim connStr As String
    connStr = "driver={sql server};server=localhost\sql2005;"
    connStr = connStr & "Database=AdventureWorks;TrustedConnection=True;"

    ' Setup the connection to the database
    Dim connection As ADODB.connection
    Set connection = New ADODB.connection
    connection.connectionString = connStr
    ' Open the connection
    connection.Open

    ' Open recordset.
    Set Cmd1 = New ADODB.Command
    Cmd1.ActiveConnection = connection
    Cmd1.CommandText = "SELECT Name FROM Production.Product ORDER BY Name"
    Set Results = Cmd1.Execute()

    UserForm2.listProducts.MultiSelect = fmMultiSelectMulti
    Results.MoveFirst
    While Not Results.EOF

        UserForm2.listProducts.AddItem Results.Fields("Name").Value
        Results.MoveNext

    Wend

    UserForm2.Show
End Sub

Private Sub btnProducts_Click()

    Dim selection As String
    ' Get the selected products escaping single quotes
    'selection = Replace(UserForm2.listProducts.Value, "'", "''")
    Dim lItem As Long

    For lItem = 0 To listProducts.ListCount - 1

        If listProducts.Selected(lItem) = True Then

            selection = selection & "'" & Replace(listProducts.List(lItem), "'", "''") & "',"
        End If
    Next

    selection = Mid(selection, 1, Len(selection) - 1)

    ' Setup connection string
    Dim connStr As String
    connStr = "driver={sql server};server=localhost\sql2005;"
    connStr = connStr & "Database=AdventureWorks;TrustedConnection=True;"

    ' Setup the connection to the database
    Dim connection As ADODB.connection
    Set connection = New ADODB.connection
    connection.connectionString = connStr
    ' Open the connection
    connection.Open

    ' Open recordset.
    Set Cmd1 = New ADODB.Command
    Cmd1.ActiveConnection = connection
    Cmd1.CommandText = "SELECT * FROM Purchasing.PurchaseOrderDetail t1 INNER JOIN Production.Product t2 ON t1.ProductID = t2.ProductID AND t2.Name IN (" & selection & ")"
    Set Results = Cmd1.Execute()

    ' Clear the data from the active worksheet
    Cells.Select
    Cells.ClearContents

    ' Add column headers to the sheet
    headers = Results.Fields.Count
    For iCol = 1 To headers
       Cells(1, iCol).Value = Results.Fields(iCol - 1).Name
    Next

    ' Copy the resultset to the active worksheet
    Cells(2, 1).CopyFromRecordset Results

    ' Stop running the macro
    Unload Me

End Sub

Thanks a lot for your help in advance.