I'm having trouble getting this code to work. I have a blank form with a simple multi-select list box (GroupList) and a button underneath it (cmdSearch). I'm trying to put code into the button to pull select names from GroupList and display Group Affiliation names (field: [Group Affiliations] from table Group_Affiliations.
Private Sub cmdSearch_Click()
Dim varItem As Variant
Dim strSearch As String
Dim Task As String
For Each varItem In Me!GroupList.ItemsSelected
strSearch = strSearch & "," & Me!GroupList.ItemData(varItem)
Next varItem
MsgBox (strSearch)
If Len(strSearch) = 0 Then
Task = "select * from Group_Affiliations"
Else
strSearch = Right(strSearch, Len(strSearch) - 1)
Task = "select * from Group_Affiliations where ([Group Affiliations] in (" & strSearch & "))"
End If
DoCmd.ApplyFilter Task
End Sub
Please help. I think I'm close but it wants me to set a parameter and then I receive the error:
Error code 2501
I think you will likely get the results you want using the following code:
'Set strSearch to empty string
strSearch = ""
'Loop through as you did applying proper single quotes between items
For Each varItem In Me!GroupList.ItemsSelected
strSearch = strSearch & "'" & Me!GroupList.ItemData(varItem) & "',"
Next varItem
'MsgBox (strSearch) 'commented out as I'm sure this is for your testing
'checking if blank (as you did)
If Len(strSearch) = 0 Then
Task = "select * from Group_Affiliations"
'removing end comma and writing SQL statement
Else
strSearch = Left(strSearch, Len(strSearch) - 1)
Task = "select * from Group_Affiliations where ([Group Affiliations] in (" & strSearch & "))"
End If
DoCmd.ApplyFilter Task
If you inspect Task, you will see that the elements of the IN(... part are not quoted. As they are strings (both in VB and for the database, a text field), you must quote the components:
strSearch = strSearch & "'" & Me!GroupList.ItemData(varItem) & "',"
This worked. Thanks billyhoes and everyone! I did show the msgbox because, in this case, I do need viewers to see what they're searching.
Private Sub cmdSearch_Click()
strSearch = ""
For Each varItem In Me!GroupList.ItemsSelected
strSearch = strSearch & "'" & Me!GroupList.ItemData(varItem) & "',"
Next varItem
MsgBox (strSearch)
If Len(strSearch) = 0 Then
Task = "select * from Group_Affiliations"
Else
strSearch = Left(strSearch, Len(strSearch) - 1)
Task = "select * from Group_Affiliations where ([Group Affiliations] in (" & strSearch & "))"
End If
DoCmd.ApplyFilter Task
End Sub
Related
I have a form (frmSearch) that I use several (4) comboboxes to filter out results for a listbox (lstCustomers). What I'm attempting to do now is create the ability to filter the listbox based on a text box of "keywords". Additionally, the column which the keyword box will search will be variable based on cboWhere which is a list of columns from tblContacts (the table qryContactWants uses)
I found a really nice Function set with the following code that will let me filter everything, but I'm not entirely sure how to turn this data around and use it to filter out my listbox.
This function organizes the keywords:
Public Function FindAnyWord(varFindIn, strWordList As String) As Boolean
Dim var
Dim aWords
aWords = Split(strWordList, ",")
For Each var In aWords
If FindWord(varFindIn, var) Then
FindAnyWord = True
Exit Function
End If
Next var
End Function
And this function actually performs the search:
Public Function FindWord(varFindIn As Variant, varWord As Variant) As Boolean
Const PUNCLIST = """' .,?!:;(){}[]-—/"
Dim intPos As Integer
FindWord = False
If Not IsNull(varFindIn) And Not IsNull(varWord) Then
intPos = InStr(varFindIn, varWord)
' loop until no instances of sought substring found
Do While intPos > 0
' is it at start of string
If intPos = 1 Then
' is it whole string?
If Len(varFindIn) = Len(varWord) Then
FindWord = True
Exit Function
' is it followed by a space or punctuation mark?
ElseIf InStr(PUNCLIST, Mid(varFindIn, intPos + Len(varWord), 1)) > 0 Then
FindWord = True
Exit Function
End If
Else
' is it precedeed by a space or punctuation mark?
If InStr(PUNCLIST, Mid(varFindIn, intPos - 1, 1)) > 0 Then
' is it at end of string or followed by a space or punctuation mark?
If InStr(PUNCLIST, Mid(varFindIn, intPos + Len(varWord), 1)) > 0 Then
FindWord = True
Exit Function
End If
End If
End If
' remove characters up to end of first instance
' of sought substring before looping
varFindIn = Mid(varFindIn, intPos + 1)
intPos = InStr(varFindIn, varWord)
Loop
End If
End Function
And here is the code that I typically use to filter the listbox using the comboboxes on frmSearch:
Dim column As String
SQL = "SELECT qryContactWants.ID, qryContactWants.FullName, qryContactWants.Type, qryContactWants.Make, qryContactWants.Model, qryContactWants.YearWanted, qryContactWants.Condition " _
& "FROM qryContactWants " _
& "WHERE 1=1 "
If cboType.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.Type = '" & cboType.Value & "'"
End If
If cboMake.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.Make = '" & cboMake.Value & "'"
End If
If cboModel.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.Model = '" & cboModel.Value & "'"
End If
If cboYear.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.YearWanted = '" & cboYear.Value & "'"
End If
If cboCondition.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.Condition = '" & cboCondition.Value & "'"
End If
SQL = SQL & " ORDER BY qryContactWants.Last"
Me.lstCustomers.RowSource = SQL
Me.lstCustomers.Requery
End Sub
What I would like to do is take the functions I found for searching keywords and apply it to my form and aid in returning a list of customers in lstCustomers
Ideally, having the keyword function return an SQL statement similar to those I'm using to filter out the listbox would be perfect. This would allow me to add a simple SQL = SQL & "AND qryContactWants.VARIABLECOLUMNHERE =SOMETHING
EDIT 1:
While using the following code, VBA is tossing a compile error on the second "End If" stating there isn't a Block If. There clearly is, so I'm not sure what's going on. Here is the code I'm using:
Public Function KeyWhere(strKeys As String, strColumn As String) As String
Dim b As Variant
strKeys = Replace(strKeys, vbCrLf, ",") ' remove all line returns
b = Split(strKeys, ",")
Dim strWhere As String
Dim v As Variant
For Each v In b
If Trim(b) <> "" Then
If strWhere <> "" Then strWhere = strWhere & " or "
strWhere = strWhere & strColumn & " like '*" & Trim(v) & "*'"
End If
End If
Next
strWhere = "(" & strWhere & ")"
KeyWhere = strWhere
End Function
And under the function RequerylistCustomers() I added the If IsNull (Me.txtSearch) = False Then code below:
Private Sub RequerylstCustomers()
Dim SQL As String
'Dim criteria As String
Dim column As String
SQL = "SELECT qryContactWants.ID, qryContactWants.FullName, qryContactWants.Type, qryContactWants.Make, qryContactWants.Model, qryContactWants.YearWanted, qryContactWants.Condition " _
& "FROM qryContactWants " _
& "WHERE 1=1 "
If cboType.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.Type = '" & cboType.Value & "'"
End If
If cboMake.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.Make = '" & cboMake.Value & "'"
End If
If cboModel.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.Model = '" & cboModel.Value & "'"
End If
If cboYear.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.YearWanted = '" & cboYear.Value & "'"
End If
If cboCondition.Value & "" <> "" Then
SQL = SQL & " AND qryContactWants.Condition = '" & cboCondition.Value & "'"
End If
Dim strWhere As String
'Grab Keywords from txtSearch using cboWhere to search for those keywords
If IsNull(Me.txtSearch) = False Then
strWhere = KeyWhere(Me.txtSearch, Me.cboWhere)
SQL = SQL & " AND " & strWhere
End If
SQL = SQL & " ORDER BY qryContactWants.Last"
Me.lstCustomers.RowSource = SQL
Me.lstCustomers.Requery
End Sub
Are the keywords to be searched in a single column (say a comments or memo column?). If yes, then you should be able to optional "add" the one additional criteria to your current "set" of combo box filters.
Are we to assume that the keywords can appear anywhere in that memo column to search?
So, if there are "key words entered into that text box, then you call KeyWhere.
eg this routine:
Public Function KeyWhere(strKeys As String, strColumn As String) As String
Dim b As Variant
strKeys = Replace(strKeys, vbCrLf, ",") ' remove all line returns
b = Split(strKeys, ",")
Dim strWhere As String
Dim v As Variant
For Each v In b
if trim(v) <> "" then
If strWhere <> "" Then strWhere = strWhere & " or "
strWhere = strWhere & strColumn & " like '*" & Trim(v) & "*'"
end if
Next
strWhere = "(" & strWhere & ")"
KeyWhere = strWhere
End Function
We assume each key word is separated by a comma (could be space, but comma is better).
So, if I type in the following command in debug window to test the above?
? keywhere("Generator, Water maker, Battery","Notes")
OutPut:
(Notes like '*Generator*' or Notes like '*Water maker*' or Notes like '*Battery*')
So, we just append the above results to your final SQL.
eg:
dim strWhere as string
if isnull(me.KeyWordBox) = False then
strWhere = keyWhere(me.KeyWordBox,me.cboColumnToSearch)
SQL = SQL & " AND " & strWhere
end if
so, the above converts all keywords into a valid SQL condition for the column to search. It is likely that column is some kind of notes column, but it would work for other description type field to search.
I'm trying to filter a splitform with a listbox but I keep getting the error '3075'.
I used the debug tool and I got:
strSearch = "52185A, 515674B"
Task = "select * from tOrder where ([OrderID] in (52185A,515674B))"
I'm pretty sure I'm missing some quotations, however I couldn't seem to figure out where. They're all short text format.
Option Compare Database
Private Sub cmdSearch_Click()
Dim varltem As Variant
Dim strSearch As String
Dim Task As String
For Each varltem In Me!LstMatricule.ItemsSelected
strSearch = strSearch & "," & Me!LstMatricule.ItemData(varltem)
Next varltem
If Len(strSearch) = 0 Then
Task = "select * from tOrder"
Else
strSearch = Right(strSearch, Len(strSearch) - 1)
Task = "select * from tOrder where ((OrderID] in (" & strSearch & "))"
End If
DoCmd.ApplyFilter Task
End Sub
strSearch = strSearch & ",'" & Me!LstMatricule.ItemData(varltem) & "'"
It is difficult to see but basically I added single quotes around each varItem. You want the result to look like this:
strSearch = "'52185A', '515674B'"
Personally I would do this:
strSearch = strSearch & IIf(Len(strSearch) = 0, "", ",") & "'" & Me!LstMatricule.ItemData(varltem) & "'"
It is slightly more expensive computationally if you have more than 2-3 IDs to add but cleaner than removing the starting comma at the beginning later on.
I am creating a form on Access to filter a Subform based on the Column name "Control Type".
I am using a listbox to choose multiple values to filter with.
I also have a button that will execute the filter to the form.
I wrote this code:
Private Sub cmdSearch_Click()
Dim varItem As Variant
Dim strSearch As String
Dim Task As String
For Each varItem In Me!listControl.ItemsSelected
strSearch = strSearch & "," & Me!listControl.ItemData(varItem)
Next varItem
If Len(strSearch) = 0 Then
Task = "select * from tblAB"
Else
strSearch = Right(strSearch, Len(strSearch) - 1)
Task = "select * from tblAB where Control_Type = '" & strSearch & "' "
End If
Me.tblAB_subform.Form.Filter = Task
Me.tblAB_subform.Form.FilterOn = True
End Sub
I am getting a Run=time error '3075' for the line:
Task = "select * from tblAB where Control_Type = '" & strSearch & "' "
Run time error must not be on refered line.
From documentation:
The Filter property is a string expression consisting of a WHERE
clause without the WHERE keyword.
So is not a complete SELECT sentence, but just:
Task = "Control_Type = '" & strSearch & "'"
I have a multipleValue field which contains Multiple Designations like... Doctor,Nurse, ANM, Clerk etc.
I want to update a table where Designation Match with each Designation. My Code is following but success with First Designation only. How to Update all designation using code like.... DO Until.... Loop....Next.... in sql query
Private Sub PostAssigned_AfterUpdate()
Dim strCriteria As String
Dim varItem As Variant
Dim intCounter As Integer
Dim strClear, strUpdate As String
For Each varItem In Me![PostAssigned].Value
strCriteria = strCriteria & varItem & ","
Next
strClear = "UPDATE MasterGeneralData SET MasterGeneralData.DA_ID = 0 WHERE (((MasterGeneralData.DA_ID)= " & Me.DAAAID & "));"
DoCmd.RunSQL (strClear)
strUpdate = "UPDATE MasterGeneralData SET MasterGeneralData.DA_ID = " & Me.DAAAID & " WHERE (((MasterGeneralData.Emp_Design)= '" & Left$([strCriteria], InStr([strCriteria], ",") - 1) & "'));"
DoCmd.RunSQL (strUpdate)
MsgBox "Dealing Assistant details Updated successfully "
End Sub
Yes... I got it... Working Fine..
My code is.
Private Sub PostAssigned_AfterUpdate()
Dim strCriteria As String
Dim varItem As Variant
Dim intCounter As Integer
Dim strClear, strUpdate As String
Dim LArray() As String
For Each varItem In Me![PostAssigned].Value
strCriteria = strCriteria & varItem & ","
Next
LArray = Split(strCriteria, ",")
DoCmd.SetWarnings False
strClear = "UPDATE MasterGeneralData SET MasterGeneralData.DA_ID = 0 WHERE (((MasterGeneralData.DA_ID)= " & Me.DAAAID & "));"
DoCmd.RunSQL (strClear)
For i = LBound(LArray) To UBound(LArray)
strUpdate = "UPDATE MasterGeneralData SET MasterGeneralData.DA_ID = " & Me.DAAAID & " WHERE (((MasterGeneralData.Emp_Design)= '" & LArray(i) & "'));"
DoCmd.RunSQL (strUpdate)
Next i
DoCmd.SetWarnings True
MsgBox "Dealing Assistant details Updated successfully "
End Sub
I have the following vba that creates a query in a test Access database. I have two multiple select list boxes. The issue is, i want to be able to select multiple items from "Me![State]" and none from "Me![Animal]" and be able to run the query. However, this is not possible as the query language is not set up to handle that. It makes me select something from "Me![Animal]".
How do i revise the vba below to allow me to query on both multiple selection list boxes if one of the multiple list boxes does not have anything selected or if both have selections in them?
Private Sub Command6_Click()
Dim Q As QueryDef, DB As Database
Dim Criteria As String
Dim ctl As Control
Dim Itm As Variant
Dim ctl2 As Control
Dim ctl3 As Control
' Build a list of the selections.
Set ctl = Me![Animal]
For Each Itm In ctl.ItemsSelected
If Len(Criteria) = 0 Then
Criteria = Chr(34) & ctl.ItemData(Itm) & Chr(34)
Else
Criteria = Criteria & "," & Chr(34) & ctl.ItemData(Itm) _
& Chr(34)
End If
Next Itm
If Len(Criteria) = 0 Then
Itm = MsgBox("You must select one or more items in the" & _
" list box!", 0, "No Selection Made")
Exit Sub
End If
Set ctl2 = Me![State]
For Each Itm In ctl2.ItemsSelected
If Len(Criteria2) = 0 Then
Criteria2 = Chr(34) & ctl2.ItemData(Itm) & Chr(34)
Else
Criteria2 = Criteria2 & "," & Chr(34) & ctl2.ItemData(Itm) _
& Chr(34)
End If
Next Itm
If Len(Criteria2) = 0 Then
Itm = MsgBox("You must select one or more items in the" & _
" list box!", 0, "No Selection Made")
Exit Sub
End If
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
Q.SQL = "Select * From [table1] Where [table1].[type] In (" & "'Animal'" & _
")" & " and [table1].[animal] in (" & Criteria & _
")" & " and [table1].[state] in (" & Criteria2 & _
")" & ";"
Q.Close
' Run the query.
DoCmd.OpenQuery "animalquery"
End Sub
EDIT - Fix comparison as per comment
You can do this with a simple check of your Criteria vaiables.
You already do the the length check - just use it later on when you build the dynamic SQL.
I added a strSQL variable to make it easier to track what's happening. And adjusted the error message to allow one or other criteria being empty
Private Sub Command6_Click()
Dim Q As QueryDef
Dim DB As Database
Dim Criteria As String
Dim ctl As Control
Dim Itm As Variant
Dim ctl2 As Control
Dim ctl3 As Control
' Use for dynamic SQL statement'
Dim strSQL As String
Set ctl = Me![Animal]
For Each Itm In ctl.ItemsSelected
If Len(Criteria) = 0 Then
Criteria = Chr(34) & ctl.ItemData(Itm) & Chr(34)
Else
Criteria = Criteria & "," & Chr(34) & ctl.ItemData(Itm) & Chr(34)
End If
Next Itm
Set ctl2 = Me![State]
For Each Itm In ctl2.ItemsSelected
If Len(Criteria2) = 0 Then
Criteria2 = Chr(34) & ctl2.ItemData(Itm) & Chr(34)
Else
Criteria2 = Criteria2 & "," & Chr(34) & ctl2.ItemData(Itm) & Chr(34)
End If
Next Itm
If (Len(Criteria) = 0) And (Len(Criteria2) = 0) Then
Itm = MsgBox("You must select one or more items from one of the list boxes!", 0, "No Selection Made")
Exit Sub
End If
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
strSQL = "Select * From [table1] Where [table1].[type] In (" & "'Animal')"
If (Len(Criteria) <> 0) Then ' Append Animal Criteria
strSQL = strSQL & " AND [table1].[animal] IN (" & Criteria & ")"
End If
If (Len(Criteria2) <> 0) Then ' Append State Criteria
strSQL = strSQL & " AND [table1].[state] IN (" & Criteria2 & ")"
End If
Q.SQL = strSQL
Q.Close
' Run the query.
DoCmd.OpenQuery "animalquery"
End Sub