I have a datasheet on a form with a qdf as recordsource.
I'd like to provide ability to search a specific column in the datasheet for the first/next occurrence (row) of the wildcarded string from a textbox on the same form (e.g., Jump to NEXT RECORD with MfgID like 123).
I'm not really looking for a FILTER, as I need to see the matching record(s) in context of surrounding records.
Any suggestions how to begin?
Thanks HansUp for the pointer. Here is what I implemented:
1. Sets focus to the desired column
2. Supports multiple btn clicks, to keep looking for the NEXT occurence
3. When no_match or end of list, returns to first record, clears txtSearch
--------------
Private Sub btnSearch_Click()
Dim rs As Object
On error goto err_handler
Forms![myForm]![mySubform].Form![MFGID].SetFocus
Set rs = Forms![myForm]![mySubform].Form.RecordsetClone
rs.FindNext "[MfgID] like '*" & Me![txtSearch] & "*'"
If Not Trim(Me![txtSearch]) = "" Then
Forms![myForm]![mySubform].Form.Bookmark = rs.Bookmark
Else
MsgBox "Please enter search criteria.", vbOKOnly, "Error"
Me![txtSearch].SetFocus
Exit Sub
End If
If Not rs.NoMatch Then
Forms![myForm]![mySubform].Form.Bookmark = rs.Bookmark
Else
MsgBox "Match not found for: " & Me![txtSearch] & "", , "Error"
rs.MoveFirst
Forms![myForm]![mySubform].Form.Bookmark = rs.Bookmark
Me![txtSearch] = ""
End If
err_exit:
Exit Sub
err_handler:
If Err.Number = 2455 Then GoTo err_exit
MsgBox Err.Number
exit sub
Related
I have a textbox on a form that is filtering my data by the company name. The reason for the close and open code in the error handling is because I couldn't find a way to easily fix it throwing an error when a combination of characters not present would be entered. This way it just closes and reopens it and basically resets it. I am still fairly new to this development and all I know is taught to myself through google and forums like this so forgive my lack of understanding when things should make sense to someone else able to do these types of functions.
Upon typing part of a company name and pressing space to type in a second word it essentially removes the space and puts the cursor back to the last letter typed.
This is the code for the textbox.
Reminder that I find solutions to the functions I need and adapt the code as best I can to suit my needs. I don't pretend to fully comprehend what I use yet and I'm still learning.
Private Sub txtSearch_KeyUp(KeyCode As Integer, Shift As Integer)
On Error GoTo errHandler
Dim filterText As String
'Apply or update filter based on user input.
If Len(txtSearch.Text) > 0 Then
filterText = txtSearch.Text
Me.Form.Filter = "[tblSuppliers]![SupplierName] like '*" & filterText & "*'"
Me.FilterOn = True
'Retain filter text in search box after refresh
txtSearch.Text = filterText
txtSearch.SelStart = Len(txtSearch.Text)
Else
'Remove filter
Me.Filter = ""
Me.FilterOn = False
txtSearch.SetFocus
End If
Exit Sub
errHandler:
MsgBox Err.Number & " - " & Err.Description, vbInformation + vbOKOnly, "Information"
DoCmd.Close acForm, "frmCosteeDetails", acSaveNo
DoCmd.OpenForm "frmCosteeDetails"
End Sub
In my search to try and find a way to fix the removal of spaces I found this function that someone listed but wasn't sure how to integrate it into my code.
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
Edit - Code for Current Solution
Private Sub txtSearch_Change()
On Error GoTo errHandler
'clear filter
If Len(txtSearch.Text) = 0 Then
FilterOn = False
Filter = vbNullString
Exit Sub
End If
'apply filter
Filter = "[SupplierName] like '*" & txtSearch.Text & "*'"
FilterOn = True
Leave:
Exit Sub
errHandler:
MsgBox Err.Number & " - " & Err.Description, vbInformation + vbOKOnly, "Information"
Resume Leave
'DoCmd.Close acForm, "frmCosteeDetails", acSaveNo
'DoCmd.OpenForm "frmCosteeDetails"
End Sub
A simple filter method is as shown below. You will need to handle the Change() event and use the Text property which is populated on every keystroke.
Also, filtering does not requery data, so no need to try to manually retain the search value.
The below assumes the txtSearch and the data due to be filtered are on the same form. If that's not the case, the reference to the data-form will need to be changed.
Private Sub txtSearch_Change()
On Error GoTo errHandler
'clear filter
If Len(txtSearch.Text) = 0 Then
FilterOn = False
Filter = vbNullString
Exit Sub
End If
'apply filter
Filter = "[SupplierName] like '*" & txtSearch.Text & "*'"
FilterOn = True
Leave:
Exit Sub
errHandler:
MsgBox Err.Number & " - " & Err.Description, vbInformation + vbOKOnly, "Information"
Resume Leave
End Sub
Rather than using a text box to constantly update as typed just change it to a search button that when clicked searches based on the value in the search box. All you have to do is then update the search criteria each time and click search. a bit slower but functions mostly the same.
Private Sub cmdSearch_Click()
Dim strWhere As String
strWhere = "[tblSuppliers]![SupplierName] Like '*" & Me.txtSearch & "*'"
'Apply Filter
Me.Filter = strWhere
Me.FilterOn = True
End Sub
I have a form that if a duplicate record is entered, the form creates an error message and prevents the record from being entered. However, my code is popping up the error message no matter what I'm putting in. My code is this...
Private Sub cmdSave_Click()
' ToDo fix the labels in this function so they match the function name. Just cosmetic.
On Error GoTo Add_CmdSave_Click_Err
On Error Resume Next
' ToDo fix the labels in this function so they match the function name. Just cosmetic.
On Error GoTo Add_CmdSave_Click_Err
On Error Resume Next
Me.cbCompletedTrainingID = Me.IntermediateID
'
Dim OKToSave As Boolean
OKToSave = True
If Not SomethingIn(Me.[fIntermediate FacultyID]) Then ' Null
Beep
MsgBox "A faculty member is required", vbOKOnly, "Missing Information"
OKToSave = False
End If
If Not SomethingIn(Me.[fIntermediate TrainingID]) Then
Beep
MsgBox "A training is required", vbOKOnly, "Missing Information"
OKToSave = False
Else
Dim rs As Object
Set rs = Me.Recordset.Clone
rs.FindFirst "[IntermediateID] = " & Me.[fIntermediate FacultyID] And Me.[fIntermediate TrainingID]
If Not rs.EOF Then
Beep
MsgBox "This person has already completed this training", vbOKOnly, "Duplicate Training Completion"
OKToSave = False
End If
End If
If OKToSave Then
' If we get this far, all data is valid and it's time to save
Me.Dirty = False
DoCmd.GoToRecord , "", acNewRec
End If
Add_CmdSave_Click_Exit:
Exit Sub
Add_CmdSave_Click_Err:
Resume Add_CmdSave_Click_Exit
End Sub
The issue, from my standpoint, lies in this part...
Dim rs As Object
Set rs = Me.Recordset.Clone
rs.FindFirst "[IntermediateID] = " & Me.[fIntermediate FacultyID] And Me.[fIntermediate TrainingID]
If Not rs.EOF Then
Beep
MsgBox "This person has already completed this training", vbOKOnly, "Duplicate Training Completion"
OKToSave = False
End If
What am I doing wrong?
Have a look at How to debug dynamic SQL in VBA.
This line makes no sense as it is:
rs.FindFirst "[IntermediateID] = " & Me.[fIntermediate FacultyID] And Me.[fIntermediate TrainingID]
You probably want something like
S = "[IntermediateID] = " & Me.[fIntermediate FacultyID] & " And [TrainingID] = " & Me.[fIntermediate TrainingID]
Debug.Print S ' Ctrl+G shows the output
rs.FindFirst S
Also, remove all these On Error Resume Next - this will happily ignore any errors, making debugging nearly impossible.
Also useful: Debugging VBA Code
And there is more: If Recordset.FindFirst doesn't find a match, it doesn't trigger .EOF. It sets the .NoMatch property.
rs.FindFirst S
If rs.NoMatch Then
' all is good, proceed to save
Else
' record exists
End If
This should work as intended:
Dim rs As DAO.Recordset
Dim Criteria As String
Set rs = Me.RecordsetClone
Criteria = "[IntermediateID] = " & Me![fIntermediate FacultyID].Value & " And [TrainingID] = " & Me![fIntermediate TrainingID].Value & ""
Debug.Print OKToSave, Criteria
rs.FindFirst Criteria
If Not rs.NoMatch Then
Beep
MsgBox "This person has already completed this training", vbInformation + vbOKOnly, "Duplicate Training Completion"
OKToSave = False
End If
rs.Close
Debug.Print OKToSave
Creating an access database for work. Users will use a split form with only the datasheet visible to review and manipulate numeric data. On the form I have built in quick filters that consist of of textboxes in which the values are either raised or lowered with arrow buttons that have on-click events. I currently have the text boxes linked to the recordsource query criteria.
With all of this stated, the problem that I am having is that I need the filter to act in the following manner:
If the value in the text box equals 0 I want to see all records. If the value is greater than 0, I want all records greater than or equal to the text box value to show. Finally, if the value in the text box is less than 0, I want to see all values less than or equal to 0.
I have considered trying to use multiple sql statements but I typically have about 3 of these quick filters on each form, and my project will eventually have about 20 forms. That is a lot of sql statements to potentially mess up.
What ideas do you guys have to solve this problem? I really need help.
If you only have 1 textbox on each form, then you may want to consider using the form's Filter property:
Private Sub txtFilter_AfterUpdate()
On Error GoTo E_Handle
If Not IsNull(Me!txtFilter) Then
If IsNumeric(Me!txtFilter) Then
Select Case Me!txtFilter
Case Is < 0
Me.Filter = "Price<=0"
Me.FilterOn = True
Case 0
Me.FilterOn = False
Case Is > 0
Me.Filter = "Price>=" & Me!txtFilter
Me.FilterOn = True
End Select
End If
End If
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!txtFilter_AfterUpdate", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
If need to have multiple filters, then consider moving the filter creation to a procedure by itself that handles all cases, and just call this procedure from each text box. You may have to think about the logic here of what happens if one text box is 0 (No filter), but another text box is 5 (display all values >= 5) and another text box is -3 (display all values <= 0):
Private Sub txtFilter2_AfterUpdate()
On Error GoTo E_Handle
Call sFilterForm2
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!txtFilter2_AfterUpdate", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Private Sub sFilterForm2()
On Error GoTo E_Handle
Dim strSQL As String
If Not IsNull(Me!txtFilter) Then
If IsNumeric(Me!txtFilter) Then
Select Case Me!txtFilter
Case Is < 0
strSQL = " AND Price<=0 "
Case 0
Case Is > 0
strSQL = strSQL & " AND Price>=" & Me!txtFilter
End Select
End If
End If
If Not IsNull(Me!txtFilter2) Then
If IsNumeric(Me!txtFilter2) Then
Select Case Me!txtFilter2
Case Is < 0
strSQL = " AND Price<=0 "
Case 0
Case Is > 0
strSQL = strSQL & " AND Price>=" & Me!txtFilter2
End Select
End If
End If
If Len(strSQL) > 0 Then
strSQL = Mid(strSQL, 5)
Me.Filter = strSQL
Me.FilterOn = True
Else
Me.FilterOn = False
End If
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!sFilterForm2", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards
Given a text box control CriteriaField1 and a corresponding field to filter Field1 in the record source I would use this:
Private Sub CriteriaField1_AfterUpdate()
Const FIELD_NAME As String = "Field1"
Dim value As Long
value = Nz(Me("Criteria" & FIELD_NAME).Value, 0)
Dim condition As String
condition = FIELD_NAME & IIf(value < 0, " <= 0", " >= " & value)
Me.FilterOn = value <> 0
End Sub
If you need to combine multiple fields to a filter condition, you would have to use and set form-global variables instead of local ones.
You could call a helper function which holds a set of arrays and builds and sets the filter dynamically:
Private Sub Filter0_AfterUpdate()
SetFilter
End Sub
Private Sub Filter1_AfterUpdate()
SetFilter
End Sub
Private Sub Filter2_AfterUpdate()
SetFilter
End Sub
Private Sub SetFilter()
Dim FieldNames() As Variant
Dim TextboxNames() As Variant
Dim Criteria() As String
Dim Index As Integer
Dim Value As Long
' Specify the field names to filter on.
FieldNames = Array("Quantity", "Stock", "Size")
' Specify the names of the textboxes to enter filter values.
TextboxNames() = Array("Filter0", "Filter1", "Filter2")
ReDim Criteria(LBound(TextboxNames) To UBound(TextboxNames))
For Index = LBound(Criteria) To UBound(Criteria)
Value = Val(Nz(Me(TextboxNames(Index)).Value))
If Value < 0 Then
Criteria(Index) = FieldNames(Index) & " <= 0"
ElseIf Value > 0 Then
Criteria(Index) = FieldNames(Index) & " >= " & CStr(Value)
Else
Criteria(Index) = "True"
End If
Next
' Assemble and apply the filter.
Me.Filter = Join(Criteria, " And ")
Me.FilterOn = True
Debug.Print Me.Filter
End Sub
how do i create a message box that shows all of the mandatory fields that have not been filled in.
I am using a table that has an auto filter on it ("Table11") to show only the checks that have failed.
I want to translate these into a message box that show when a sales agent tries to create the contract.
Table layout below:
The below sample goes through Table11 and creates a list of all those with marked with 'Check', Then displays a message if there were items.
Public Sub Sample()
Dim LngCounter As Long
Dim Tbl As Excel.Range
Dim StrMsg As String
Set Tbl = ThisWorkbook.Worksheets("Sheet1").Range("Table11")
For LngCounter = 2 To Tbl.Rows.Count
If Trim(UCase(Tbl.Cells(LngCounter, 2))) = "CHECK" Then
StrMsg = StrMsg & Tbl.Cells(LngCounter, 1) & vbNewLine
End If
Next
Set Tbl = Nothing
If StrMsg <> "" Then
MsgBox "The following items need attention before continuing: - " & vbNewLine & vbNewLine & StrMsg, vbOKOnly + vbExclamation, "Data Validation"
End If
End Sub
This assumes CHECK means there's a problem
Sub ErrorMessage()
Dim strErrMsg As String
Dim cell As Range
If Application.CountIf(-yourfilteredrangehere-), "CHECK") = 0 Then Exit Sub
'no problems to output
For Each cell In Range(-yourfilteredrangehere-)
'next line assumes checkitem in previous column, change if not
If cell = "check" Then strErrMsg = strErrMsg & "Please check " & cell.Offset(0, -1) & vbCrLf
Next cell
MsgBox strErrMsg
End Sub
I have this code with me where i can display the message when every outer loop ends. I want to catch all these messages in suppose array or soome list like structure and then at the end want to display each of these messages into one msgbox. Would appreciate if someone could help me.
Thanks.
For Each objNavFolder In objNavGroup.NavigationFolders
SkippedItemCounter = 0
If oItems.Count = 0 Then
MsgBox "No Appointments items in " & objNavFolder.DisplayName & "'s folder"
Else
NextRow = NextRow + 1
For Each MyItem In oItems
If MyItem = "" Then
SkippedItemCounter = SkippedItemCounter + 1
End If
'some code here
Next
Set objExpl = _colExpl.Add(objFolder, olFolderDisplayNormal)
NextRow = NextRow - 1
End If
MsgBox "No. of items= "&SkippedItemCounter&"skipped from"&objNavFolder.DisplayName&""
Next
End If
End If
End If
instead of calling msgboxes, create a String and keep adding the messages - at the end of code msgbox(yourString)
for example
decalare a string before the main sub
Dim yourFinalMessage As String ' or Dim yourFinalMessage$
instead of
MsgBox "No Appointments items in " & objNavFolder.DisplayName & "'s folder"
say
yourFinalMessage = yourFinalMessage & vbCrLf & & _
"No Appointments items in " & objNavFolder.DisplayName & "'s folder"
keep doing this until the loop ends.
at the end of loop say
msgbox YourFinalMessage
Not sure to exactly understand what you want, but you might try to add this to a module:
Option Explicit
Dim globalMsg as String
globalMsg = ""
Function customMsg(msg as String)
MsgBox msg
globalMsg = globalMsg & VbCrLf & msg
End Function
Just call customMsg("Your Message") to display a MsgBox and at the end, call MsgBox globalMsg to display all the messages as a single message (one per line). There are a lot of other ways to do this, it depends on you. Please be more explicit if you want any further help.