Solved: Listbox selection as a parameter in data extraction macro.

[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
Product = frmwarehouse.ListBox4.Value
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"".""Sub Product UBR Code""='" & Product & "') 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. :bow:

[abhay_547]

Hi All,

I have got the below code from an extensive google search which I think can help us in selecting the listbox items as a parameter / criteria in the query macro posted by me in the above thread.

Dim frm As Form
Dim ctl As Control
Dim varItem As Variant
Dim strSQL As String
Dim strWhere As String

For Each varItem In ctl.ItemsSelected
strWhere = strWhere & ctl.ItemData(varItem) & ", "
Next varItem


For Each varItem In ctl.ItemsSelected
strWhere = strWhere & ctl.ItemData(varItem) & ","
Next

lngLen = Len(strWhere)
If lngLen <> 0 Then 'There was at least one item selected
strWhere = "WHERE [Sub Product UBR Code] IN (" & _
Left(strWhere, lngLen-1) & ")"
Else 'No items selected - no filter
Do Nothing
End If

strSQL = strSQL & strWhere
'!End Code Fragment!**************

'Note : this assumes your listbox is returning numeric values. If it returns
'text you'll have to concatenate in some quotes to delimit them.

Can anyone help me to replicate the above code in the my query so that I can select multiple items in listbox and my query would extract data from sql table on the basis of my selected items in listbox.

Thanks for your help in advance.:bow:

[abhay_547]

Hi All,

I got the below code as well which I think can also be used in my query macro.

For Each i In Me![List0].ItemsSelected
If Criteria <> "" Then
Criteria = Criteria & " OR "
End If
Criteria = Criteria & Me![List0].ItemData(i) & "= True"
Next i
Public Function
Public Function fMultiSelect(ctlRef As ListBox) As Variant
Dim Criteria As String
Dim i As Variant

' Build criteria string from selected items in list box.
Criteria = ""
For Each i In ctlRef.ItemsSelected
If Criteria <> "" Then
Criteria = Criteria & ","
End If
Criteria = Criteria & Format(ctlRef.ItemData(i), "0000000")
Next i

fMultiSelect = Criteria
gMultiSelect = Criteria
End Function

Call:
Call fMultiSelect(Forms!frmPreSPIPComp!lstProjects)


'******************** Code Start ************************
Dim frm As Form, ctl As Control
Dim varItem As Variant
Dim strSQL As String
Set frm = Form!frmMyForm
Set ctl = frm!lbMultiSelectListbox
strSQL = "Select * from [Cost Center Mapping] where [Sub Product UBR Code]="
'Assuming long [Sub Product UBR Code] is the bound field in lb
'enumerate selected items and
'concatenate to strSQL
For Each varItem In ctl.ItemsSelected
strSQL = strSQL & ctl.ItemData(varItem) & " OR [Sub Product UBR Code]="
Next varItem

'Trim the end of strSQL
strSQL=left$(strSQL,len(strSQL)-12))
'******************** Code end ************************

Private Sub Command7_Click()
Me.Filter = "COMPANYnumber " & GetInClause(Me!lstCustomer)

' Turn on the form's filter.
Me.FilterOn = True
End Sub

Function GetInClause(lst As ListBox) As String
' Build up the In() clause for a multi-select
' list box. If the list box isn't multi-select
' return "Like '*'".

Dim strOut As String
Dim varItem As Variant

' Single select is 0, Simple multi-select is 1,
' and extended multi-select is 2.
If lst.MultiSelect > 0 Then
' Loop through all the elements
' of the ItemsSelected collection, and use
' the ItemData array to retrieve the
' associated bound value.
If lst.ItemsSelected.Count > 0 Then
For Each varItem In lst.ItemsSelected
strOut = strOut & ", " & lst.ItemData(varItem)
Next varItem
' Strip off the leading ", ".
strOut = Mid(strOut, 3)
' Build up the output string.
strOut = "In(" & strOut & ")"
Else
' If no rows selected, simply
' use all the rows.
strOut = "Like '*'"
End If
Else
' If the list box isn't multiselect,
' then return the Customer ID for the
' selected row.
strOut = " = " & lst.ItemData(lst.ListIndex)
End If
GetInClause = strOut
End Function


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.:)