Add Search button to Excel Form|VBA & Macros|Excel Forum|My Online Training Hub

Thanks for the reply Purfleet.  While company policy prevents me from sharing the actual file, I have attached a screenshot of the user form along with the "Frankenstein" code I've cobbled together with this reply.

To be a bit more clear, I'd like to provide the user the ability to enter a "Record No." in a search box which would then populate the form with the corresponding data.  The purpose behind this is to allow the user to edit the data.  The data is located in the table "Results" which is in a separate worksheet within the workbook. 

Any assistance is appreciated!

 

Option Explicit
Private ResultsTable As ListObject
Private CurrentRow As Long
Private WithEvents Calendar1 As cCalendar

' Form design and code written by Philip Treacy
' http://www.myonlinetraininghub.....ate-delete
'
'###############################################################
'# Calendar class written by #
'# Krisztina Szabó #
'# Gábor Madács #
'# Roberto Mensa (nick r) #
'# https://sites.google.com/site/.....trol-class #
'###############################################################
'

Function IsAcceptedNumber(Ctrl As MSForms.Control) As Boolean

' Checks if :
'
' Ctrl.Value > 0
' Ctr.Value can be converted to valid double
' Ctr.Value returns TRUE from IsNumeric - bear in mind $4,4 is regarded as TRUE by IsNumeric
' Ctr.Value contains zero , (commas)
' Ctr.Value contains only one . (decimal point)
' Ctr.Value contains zero currency symbols
' Ctrl.Value has maximum three decimal places
'

Dim DoubleValue As Double
Dim CurrSym As String
Dim DecSep As String
Dim ThouSep As String

'Check for system definitions of these
CurrSym = Application.International(xlCurrencyCode)
DecSep = Application.International(xlDecimalSeparator)
ThouSep = Application.International(xlThousandsSeparator)

'Ignore errors
On Error Resume Next

DoubleValue = CDbl(Ctrl.Value)

'Value can't be converted to double or is negative
If Err.Number <> 0 Or Not DoubleValue > 0 Then

'Return error handling to Excel
On Error GoTo 0
IsAcceptedNumber = False
FlagError Ctrl
Exit Function

Else

'Return error handling to Excel
On Error GoTo 0

End If

'If a decimal separator is present
If (InStr(Ctrl.Value, DecSep) > 0) Then

'Make sure the number contains a maximum of 3 decimal places
If ((Len(Mid(Ctrl.Value, InStr(Ctrl.Value, DecSep))) - 1) > 3) Then

IsAcceptedNumber = False
FlagError Ctrl
Exit Function

End If

End If

' If the value is greater than 0 AND
' is considered numeric AND
' contains 0 currency symbols AND
' contains 0 thousands separators AND
' contains no more than one decimal separator

If Ctrl.Value > 0 And IsNumeric(Ctrl.Value) And (InStr(Ctrl.Value, CurrSym) = 0) And (InStr(Ctrl.Value, ThouSep) = 0) And (Len(Ctrl.Value) - Len(Replace(Ctrl.Value, DecSep, "")) <= 1) Then

IsAcceptedNumber = True

Else

FlagError Ctrl
IsAcceptedNumber = False

End If

End Function

Sub FlagError(Ctrl As MSForms.Control)

Ctrl.BorderStyle = fmBorderStyleSingle
Ctrl.BorderColor = &HFF&

End Sub

--------------------------------------------

Sub ClearError(Ctrl As MSForms.Control)

Ctrl.BorderStyle = fmBorderStyleNone
Ctrl.BorderColor = &H80000006
Ctrl.SpecialEffect = fmSpecialEffectSunken

End Sub

--------------------------------------------

Function CheckForErrors() As Integer

Dim ErrorsFound As Integer
Dim CompletedResults As Integer
Const ResultsFields As Integer = 5
Dim aDecimal As Double
Dim Ctrl As MSForms.Control

ErrorsFound = 0
CompletedResults = ResultsFields

For Each Ctrl In ResultsForm.Controls

Select Case TypeName(Ctrl)

Case "TextBox"
'If the text box is empty
If Ctrl.Value = "" Then

'If the text box is not optional i.e. it must contain something
If Ctrl.Tag <> "Optional" Then

FlagError Ctrl
ErrorsFound = ErrorsFound + 1

Else

ClearError Ctrl
'At this point we have an empty Results field.
'Record this for now and we'll check again later
CompletedResults = CompletedResults - 1

End If

End If

Case "ComboBox"
'If the ComboBox is empty
If Ctrl.ListIndex = "" Then

'If the ComboBox is not optional i.e. it must contain something
If Ctrl.ListIndex <> "Optional" Then

FlagError Ctrl
ErrorsFound = ErrorsFound + 1

Else

ClearError Ctrl
'At this point we have an empty Results field.
'Record this for now and we'll check again later
CompletedResults = CompletedResults - 1

End If

Else

If Ctrl.ListIndex = -1 And (Ctrl.Name = "CB_Location" Or Ctrl.Name = "CB_Measure" Or Ctrl.Name = "CB_Category" Or Ctrl.Name = "CB_Manager" Or Ctrl.Name = "CB_Department" Or Ctrl.Name = "CB_RecordNo") Then

FlagError Ctrl
ErrorsFound = ErrorsFound + 1

End If

End If

End Select

Next Ctrl

'Chosen date can not be after today
'If Calendar1.Value > Date Then

' FlagError CalendarFrame
' ErrorsFound = ErrorsFound + 1

'Else

' ClearError CalendarFrame

'End If

'If all Results fields are empty
If CompletedResults = 0 Then

'Check each Results field and flag the ones in error
For Each Ctrl In ResultsForm.Controls

Select Case TypeName(Ctrl)

Case "TextBox"
If Ctrl.Value = "" And Ctrl.Tag = "Optional" Then

FlagError Ctrl

End If

Case "ComboBox"

If Ctrl.ListIndex = "" And Ctrl.Tag = "Optional" Then

FlagError Ctrl

End If

End Select

Next Ctrl

CheckForErrors = 1

Else

CheckForErrors = ErrorsFound

End If

End Function

Private Sub ResetForm()

'
' Need to reset errors here too
'

Dim Ctrl As MSForms.Control

For Each Ctrl In ResultsForm.Controls

Select Case TypeName(Ctrl)

Case "TextBox"
Ctrl.Text = ""
ClearError Ctrl

Case "ComboBox"
If Ctrl.Name = "" Or Ctrl.Name = "CB_Location" Or Ctrl.Name = "CB_Measure" Or Ctrl.Name = "CB_Category" Or Ctrl.Name = "CB_Manager" Or Ctrl.Name = "CB_Department" Or Ctrl.Name = "CB_RecordNo" Then

Ctrl.ListIndex = -1
ClearError Ctrl

End If

End Select

Next Ctrl

Calendar1.Value = Date
ClearError CalendarFrame

End Sub

--------------------------------------------

Private Sub PopulateForm(SelectedRow As Range)

With SelectedRow

CB_SearchRecord.Value = .Cells(1, 1)
Calendar1.Value = .Cells(1, 3)
CB_Measure.Value = .Cells(1, 8)
TB_Result.Value = .Cells(1, 9)
CB_Category.Value = .Cells(1, 13)
CB_Manager.Value = .Cells(1, 14)
CB_Department.Value = .Cells(1, 15)
CB_Location.Value = .Cells(1, 16)
TB_Comment.Value = .Cells(1, 17)
TB_Description.Value = .Cells(1, 18)
CB_Risk.Value = .Cells(1, 19)
TB_Impact.Value = .Cells(1, 20)
TB_Likelihood.Value = .Cells(1, 21)
TB_Level.Value = .Cells(1, 22)
TB_Who.Value = .Cells(1, 23)
TB_What.Value = .Cells(1, 24)
TB_Target.Value = .Cells(1, 25)
TB_When.Value = .Cells(1, 26)
CB_Hyperlink.Value = .Cells(1, 27)

End With

End Sub

--------------------------------------------

Private Sub UpdateRecordDisplay()

Worksheets("Results").Activate

With ResultsTable

RecordPosition.Caption = CurrentRow & " of " & .ListRows.Count
PopulateForm .ListRows(CurrentRow).Range
.ListRows(CurrentRow).Range.Select

End With

Worksheets("Dashboard").Activate

End Sub

--------------------------------------------

Private Sub ChangeRecord_SpinUp()

If ResultsTable.ListRows.Count < 1 Then Exit Sub

If CurrentRow > 1 Then

CurrentRow = CurrentRow - 1

UpdateRecordDisplay

End If

End Sub

--------------------------------------------

Private Sub ChangeRecord_SpinDown()

If CurrentRow = ResultsTable.ListRows.Count Then Exit Sub

If CurrentRow < ResultsTable.ListRows.Count Then

CurrentRow = CurrentRow + 1

UpdateRecordDisplay

End If

End Sub

--------------------------------------------

Private Sub UpdatePositionCaption()

RecordPosition.Caption = CurrentRow & " of " & ResultsTable.ListRows.Count

End Sub

--------------------------------------------

Private Sub ClearForm_Click()

ResetForm

End Sub

--------------------------------------------

Private Sub DeleteResults_Click()

If ResultsTable.ListRows.Count < 1 Then Exit Sub

Dim promptanswer As Integer

promptanswer = MsgBox("Are you sure you want to delete this record?", vbYesNo + vbQuestion, "Confirm deleting record")

If promptanswer = vbYes Then

Sheets("Results").Unprotect Password:="xxxxxx"

Worksheets("Results").Activate

ResultsTable.ListRows(CurrentRow).Delete

If ResultsTable.ListRows.Count > 0 Then

If CurrentRow > ResultsTable.ListRows.Count Then

CurrentRow = ResultsTable.ListRows.Count

End If
Else
CurrentRow = 0

End If

Worksheets("Dashboard").Activate

ChangeRecord.Max = ChangeRecord.Max - 1

UpdateRecordDisplay

UpdatePositionCaption

Sheets("Results").Protect Password:="xxxxxx"

Else
'do nothing
End If
End Sub

--------------------------------------------

Private Sub UpdateResults_Click()

If CheckForErrors > 0 Or ResultsTable.ListRows.Count < 1 Then Exit Sub

ModifyTableRow ResultsTable.ListRows(CurrentRow).Range

End Sub

--------------------------------------------

Private Sub CloseForm_Click()

Unload ResultsForm

End Sub

--------------------------------------------

Private Sub AddResults_Click()

Sheets("Results").Unprotect Password:="xxxxxx"

If CheckForErrors > 0 Then Exit Sub

Sheets("Results").ListObjects("Results").ListRows.Add

ModifyTableRow ResultsTable.ListRows(ResultsTable.ListRows.Count).Range

UpdatePositionCaption

Sheets("Results").Protect Password:="xxxxxx"

End Sub

--------------------------------------------

Private Sub ModifyTableRow(TableRow As Range)

Sheets("Results").Unprotect Password:="xxxxxx"

With TableRow

.Cells(1, 2) = Calendar1.Value
.Cells(1, 8) = CB_Measure.Value
.Cells(1, 9) = TB_Result.Value
.Cells(1, 13) = CB_Category.Value
.Cells(1, 14) = CB_Manager.Value
.Cells(1, 15) = CB_Department.Value
.Cells(1, 16) = CB_Location.Value
.Cells(1, 17) = TB_Comment.Value
.Cells(1, 18) = TB_Description.Value
.Cells(1, 19) = CB_Risk.Value
.Cells(1, 20) = TB_Impact.Value
.Cells(1, 21) = TB_Likelihood.Value
.Cells(1, 22) = TB_Level.Value
.Cells(1, 23) = TB_Who.Value
.Cells(1, 24) = TB_What.Value
.Cells(1, 25) = TB_Target.Value
.Cells(1, 26) = TB_When.Value
.Cells(1, 27) = CB_Hyperlink.Value

End With

ChangeRecord.Max = ResultsTable.ListRows.Count

Sheets("Results").Protect Password:="xxxxxx"

End Sub

--------------------------------------------

Private Sub UserForm_Initialize()
Set ResultsTable = Sheets("Results").ListObjects("Results")

If Calendar1 Is Nothing Then

Set Calendar1 = New cCalendar

With Calendar1

.Add_Calendar_into_Frame Me.CalendarFrame
.UseDefaultBackColors = False
.DayLength = 3
.MonthLength = mlENShort
.Height = 142
.Width = 180
.GridFont.Size = 7
.DayFont.Size = 7
.Refresh

End With

End If

'Initialise for empty table
ChangeRecord.Min = 0
ChangeRecord.Max = 0

CurrentRow = ResultsTable.ListRows.Count

If CurrentRow > 0 Then

ChangeRecord.Min = 1

ChangeRecord.Max = ResultsTable.ListRows.Count

'Load last record into form

'Worksheets("Results").Activate

'PopulateForm ResultsTable.ListRows(ResultsTable.ListRows.Count).Range

'ResultsTable.ListRows(ResultsTable.ListRows.Count).Range.Select

'UpdatePositionCaption

Worksheets("Dashboard").Activate

Else

RecordPosition.Caption = "0 of 0"

End If

End Sub

Phillip,

Thank you!  I was able to take your code and combine it with the existing "UpdateRecordDisplay" and "UpdagePositionCaption" subs to make it work nicely.

Private Sub SearchResults_Click()

Dim RecordRow As Long
Dim RecordRange As Range
'Debug.Print TextBox1.Value
'Range("Table1[Record]").Select

On Error Resume Next
RecordRow = Application.Match(CLng(TB_RecordNo.Value), Range("Results[Record]"), 0)
'Range("Table1").Cells(1, 1).Offset(RecordRow - 1, 0).Select
Set RecordRange = Range("Results").Cells(1, 1).Offset(RecordRow - 1, 0)

'Debug.Print Err.Number

If Err.Number <> 0 Then

TB_RecordNo.Value = "Record not found."
On Error GoTo 0
Exit Sub

End If

On Error GoTo 0

UpdateRecordDisplay

UpdatePositionCaption

Me.TB_RecordNo.Value = ""

End Sub

 

The dashboard I've created has been well received within my organization and in all sincerity, I absolutely could not have done it without the great information and support received from myonlinetraininghub.  What a tremendous resource it's been for someone like me!

 

My Best,

Tom