Creating a user form search query with option to edit results

WombatTrax

New Member
Joined
Jul 10, 2012
Messages
10
I am trying to create a search query on a user form that is linked to a seperate spreadsheet. I have 3 text fields in the userform that can be filled in. Using a command button, I would like the userform to search any or all 3 columns linked to the text fields and return the results in a list. The user should then be able to select the row with the correct data and be able to edit any of the 9 fields of that row, then save it with the updated data.I would also like a message box to appear that says "No results found" if there are no matches in the database. Is this possible? I am fairly new to VBA and am unsure of how to code this. Also, the company I work for is limited to using excel 2003 on windows XP. Thank you in advance for any advice/help.
 
UserForm setup:

12 TextBoxes
3 named: tbSrch1 thru tbSrch3 (what you’re searching for)
9 named: tbResCol1 thru tbResCol9 (populates with ListBox selection to allow edits)

1 ListBox
Named: lbResList
ColumnWidths: Enter at minimum 1 zero – this is to hide the first column which we use for coding.
You can also enter addition column widths separate by commas to adjust the remaining columns.
You may also want the Headers to show in the ListBox – set ColumnHeads to True

2 CommandButtons
1 named: buttSrch
1 named: buttUpdate

Places all code in UserForm.
In a few places note the “change to suite” comments and change as needed.

Let me know how you make out.
Code:
Option Explicit
    Dim rgData As Range
    Dim rgResults As Range
    Dim ListRow As Long
    Dim SkipEvent As Boolean
    Dim shData As Worksheet

Private Sub buttSrch_Click()
    Dim shCurrent As Worksheet
    Dim shResults As Worksheet
    Dim found As Range
    Dim firstFound As String
    Dim SrchCol_1 As String
    Dim SrchCol_2 As String
    Dim SrchCol_3 As String
    Dim r As Long
    
    If tbSrch1 = "" And tbSrch2 = "" And tbSrch3 = "" Then Exit Sub
    
    Set shData = Sheets("Data") 'change to suit
    Set rgData = shData.Cells.CurrentRegion
    Set rgData = rgData.Offset(1, 0).Resize(rgData.Rows.Count - 1, rgData.Columns.Count)
    
    Set shCurrent = ActiveSheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Results").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Results"
    Set shResults = Sheets("Results")
    With shResults
        .Cells(1, 1) = "DataRow"
        
        .Cells(1, 2) = "Header 1" 'change to suit
        .Cells(1, 3) = "Header 2"
        .Cells(1, 4) = "Header 3"
        .Cells(1, 5) = "Header 4"
        .Cells(1, 6) = "Header 5"
        .Cells(1, 7) = "Header 6"
        .Cells(1, 8) = "Header 7"
        .Cells(1, 9) = "Header 8"
        .Cells(1, 10) = "Header 9"
    End With
    
    'columns to search thru - change to suit
    SrchCol_1 = "A"
    SrchCol_2 = "D"
    SrchCol_3 = "C"
    
    lbResList.ListIndex = -1
    tbResCol1 = ""
    tbResCol2 = ""
    tbResCol3 = ""
    tbResCol4 = ""
    tbResCol5 = ""
    tbResCol6 = ""
    tbResCol7 = ""
    tbResCol8 = ""
    tbResCol9 = ""
    
    r = 1
    If tbSrch1 <> "" Then
        With rgData.Columns(SrchCol_1)
            Set found = .Find(tbSrch1, rgData.Cells(rgData.Rows.Count, SrchCol_1))
            If Not found Is Nothing Then
                firstFound = found.Address
                Do
                    r = r + 1
                    found.EntireRow.Copy shResults.Cells(r, 1)
                    shResults.Cells(r, 1).Insert Shift:=xlToRight
                    shResults.Cells(r, 1) = found.Row
                    Set found = .FindNext(found)
                Loop While Not found Is Nothing And found.Address <> firstFound
            End If
        End With
    End If
    If tbSrch2 <> "" Then
        With rgData.Columns(SrchCol_2)
            Set found = .Find(tbSrch2, rgData.Cells(rgData.Rows.Count, SrchCol_2))
            If Not found Is Nothing Then
                firstFound = found.Address
                Do
                    r = r + 1
                    found.EntireRow.Copy shResults.Cells(r, 1)
                    shResults.Cells(r, 1).Insert Shift:=xlToRight
                    shResults.Cells(r, 1) = found.Row
                    Set found = .FindNext(found)
                Loop While Not found Is Nothing And found.Address <> firstFound
            End If
        End With
    End If
    If tbSrch3 <> "" Then
        With rgData.Columns(SrchCol_3)
            Set found = .Find(tbSrch3, rgData.Cells(rgData.Rows.Count, SrchCol_3))
            If Not found Is Nothing Then
                firstFound = found.Address
                Do
                    r = r + 1
                    found.EntireRow.Copy shResults.Cells(r, 1)
                    shResults.Cells(r, 1).Insert Shift:=xlToRight
                    shResults.Cells(r, 1) = found.Row
                    Set found = .FindNext(found)
                Loop While Not found Is Nothing And found.Address <> firstFound
            End If
        End With
    End If
    If r = 1 Then
        lbResList.RowSource = ""
        MsgBox "No Results"
    Else
        Set rgResults = shResults.Cells.CurrentRegion
        Set rgResults = rgResults.Offset(1, 0).Resize(rgResults.Rows.Count - 1, rgResults.Columns.Count)
        rgResults.RemoveDuplicates Columns:=Array(1), Header:=xlNo
        Set rgResults = shResults.Cells.CurrentRegion
        Set rgResults = rgResults.Offset(1, 0).Resize(rgResults.Rows.Count - 1, rgResults.Columns.Count)
        ActiveWorkbook.Names.Add Name:="rgResults", RefersTo:=rgResults
        lbResList.RowSource = "rgResults"
    End If
    
    shCurrent.Activate
    Application.ScreenUpdating = True
End Sub

Private Sub buttUpdate_Click()
    Dim DataRow As Long
    On Error Resume Next
    DataRow = lbResList.List(lbResList.ListIndex, 0)
    On Error GoTo 0
    If DataRow = 0 Then Exit Sub
    SkipEvent = True
        If tbResCol1 = "" And tbResCol2 = "" And tbResCol3 = "" And _
           tbResCol4 = "" And tbResCol5 = "" And tbResCol6 = "" And _
           tbResCol7 = "" And tbResCol8 = "" And tbResCol9 = "" Then
            If MsgBox("Delete Entire Record?", vbExclamation + vbYesNo, "Confirm") = vbNo Then
                Exit Sub
            Else
                shData.Rows(DataRow).EntireRow.Delete
                ListRow = lbResList.ListIndex + 1
                rgResults.Rows(ListRow).EntireRow.Delete
            End If
        Else
            If MsgBox("Do updates?", vbExclamation + vbYesNo, "Confirm") = vbNo Then
                Exit Sub
            Else
                With shData
                    .Cells(DataRow, 1) = tbResCol1
                    .Cells(DataRow, 2) = tbResCol2
                    .Cells(DataRow, 3) = tbResCol3
                    .Cells(DataRow, 4) = tbResCol4
                    .Cells(DataRow, 5) = tbResCol5
                    .Cells(DataRow, 6) = tbResCol6
                    .Cells(DataRow, 7) = tbResCol7
                    .Cells(DataRow, 8) = tbResCol8
                    .Cells(DataRow, 9) = tbResCol9
                End With
                With rgResults
                    ListRow = lbResList.ListIndex + 1
                    .Cells(ListRow, 2) = tbResCol1
                    .Cells(ListRow, 3) = tbResCol2
                    .Cells(ListRow, 4) = tbResCol3
                    .Cells(ListRow, 5) = tbResCol4
                    .Cells(ListRow, 6) = tbResCol5
                    .Cells(ListRow, 7) = tbResCol6
                    .Cells(ListRow, 8) = tbResCol7
                    .Cells(ListRow, 9) = tbResCol8
                    .Cells(ListRow, 10) = tbResCol9
                End With
            End If
        End If
    SkipEvent = False
End Sub

Private Sub lbResList_Click()
    If SkipEvent Then Exit Sub
    With lbResList
        ListRow = .ListIndex
        tbResCol1 = .List(ListRow, 1)
        tbResCol2 = .List(ListRow, 2)
        tbResCol3 = .List(ListRow, 3)
        tbResCol4 = .List(ListRow, 4)
        tbResCol5 = .List(ListRow, 5)
        tbResCol6 = .List(ListRow, 6)
        tbResCol7 = .List(ListRow, 7)
        tbResCol8 = .List(ListRow, 8)
        tbResCol9 = .List(ListRow, 9)
    End With
End Sub
 
Upvote 0
Two changes:
Both in the “Private Sub buttUpdate_Click”
Under the two “If MsgBox…” statements,
Add new line “SkipEvent = False”
After “If MsgBox…”
And before “Exit Sub”
 
Upvote 0
Warship-
Thanks for the reply and all the coding work. I can't seem to get this to work though. I keep recieving a
"Run-time error '13': Type mismatch" at:
With rgData.Columns(SrchCol_1)

Not sure why. I copied and replaced as instructed. I would post my workbook as an attachment, but I am not currently allowed to do so. Any way I might be able to send it to you so you might be able to find the problem?
 
Upvote 0
Was WombatTrax's question regarding the Run-time error ever answered? I got the same error and hope to get a fix.
Thank you!!!!
 
Upvote 0
Not really on topic but

Warship, you are a genius, your code is exactly what I was looking for, thank you!!!
 
Upvote 0
Sorry to hijack your thread, but does anyone know how to change Warships code so that another field shows in the listbox ? i.e. not the row count
 
Upvote 0

Forum statistics

Threads
1,226,771
Messages
6,192,917
Members
453,766
Latest member
Gskier

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top