Can you provide an example of what you are looking for and where the data is held with in the workbook?

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 ' https://www.myonlinetraininghub.com/excel-forms-insert-update-delete ' '############################################################### '# Calendar class written by # '# Krisztina Szabó # '# Gábor Madács # '# Roberto Mensa (nick r) # '# https://sites.google.com/site/e90e50/calendar-control-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

Hi Tom,

In the attached workbook I've created a form that will search a table to match a record number, then populate the form fields with the data from that matching row.  You should be able to adapt this code to your own situation.

The code uses structured references to access the table so you'll need to modify this according to your data.

If you have any questions about it please ask.

Regards

Phil

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

No worries Tom.  Glad that we can help and great to hear that it's had a positive impact at your work.

All the best for 2020.

Regards

Phil

Tom, I am not sure if you will receive this message being that it has been years ago since you created the thread but I thought I would try. First of all I apologize for asking it in the thread but I cannot find a method for reaching out to you directly. I would like to know if you would be willing to share the template you created for your team. I am interested in learning from it and trying to create something like you have created. Thank you for your time and support. If you need to email me directly please use [email protected].

Thanks

@philipt 
Phillip,
This is my very first post in this forum, I scavenged internet to find an answer to my question, and I am glad to coming in this forum, a lot of good info here.

I am looking for the same info on this topic, adding a search button in a form, with the option to update the results.

In your answer you said you add the workbook, but I cannot see any way to download it, can you help me with that ?

Hi,

As mentioned in the very first message in this topic, the discussion is related to Excel Forms article:

https://www.myonlinetraininghub.com/excel-forms

Go to that page, there is a download there.

Cheers,

Catalin