HI Guys,
I have basically tried to adapt a userform i found to a spreadsheet that i have, so far i think for a beginner i have done really well but these final touches have defeated me when i try one thin another stops working so i would love some help.
what i need is:
tbsrch 1, 2 ,3 i need to be able to either search for the data individually or combined ie, search for people who meet all three criteria, just two criteria, or only one
tblrescol 4, 5, 9, needs to be a selection box that when updated on the form will place a "Y" in the corresponding cell
tblrescol6 needs to be date formatted
lbreslist needs to show the name of the comapny in Column a instead A instead of the row number
tbsrch4 needs to search column A, have tried to copy all the VBA but just doesn't seem to work.
also for some reason, whenever i search it automatically creates a new sheet called "results", is it possible to stop this happening every time i try the form stops
if someone could help me that would be great
the code is as follows:
I have basically tried to adapt a userform i found to a spreadsheet that i have, so far i think for a beginner i have done really well but these final touches have defeated me when i try one thin another stops working so i would love some help.
what i need is:
tbsrch 1, 2 ,3 i need to be able to either search for the data individually or combined ie, search for people who meet all three criteria, just two criteria, or only one
tblrescol 4, 5, 9, needs to be a selection box that when updated on the form will place a "Y" in the corresponding cell
tblrescol6 needs to be date formatted
lbreslist needs to show the name of the comapny in Column a instead A instead of the row number
tbsrch4 needs to search column A, have tried to copy all the VBA but just doesn't seem to work.
also for some reason, whenever i search it automatically creates a new sheet called "results", is it possible to stop this happening every time i try the form stops
if someone could help me that would be great
the code is as follows:
Code:
[COLOR=#333333]Option Explicit[/COLOR]
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit;"> Dim rgData As Range Dim rgResults As Range Dim ListRow As Long Dim SkipEvent As Boolean Dim shData As WorksheetPrivate Sub buttSrch_Click() Dim shCurrent As Worksheet Dim shResults As Worksheet Dim found As Range Dim firstFound As String Dim SrchCol_4 As String Dim SrchCol_5 As String Dim SrchCol_6 As String Dim SrchCol_1 As String Dim r As Long If tbsrch1 = "" And tbsrch2 = "" And tbsrch3 = "" And tbsrch4 = "" Then Exit Sub Set shData = Sheets("main sheet") '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_4 = "D" SrchCol_5 = "E" SrchCol_6 = "F" SrchCol_1 = "G" lbreslist.ListIndex = -1 tbrescol1 = "" tbrescol2 = "" tbrescol3 = "" tbrescol4 = "" tbrescol5 = "" tbrescol6 = "" tbrescol7 = "" tbrescol8 = "" tbrescol9 = "" r = 1 If tbsrch1 <> "" Then With rgData.Columns(SrchCol_4) Set found = .Find(tbsrch1, rgData.Cells(rgData.Rows.Count, SrchCol_4)) 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_5) Set found = .Find(tbsrch2, rgData.Cells(rgData.Rows.Count, SrchCol_5)) 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_6) Set found = .Find(tbsrch3, rgData.Cells(rgData.Rows.Count, SrchCol_6)) 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_1) Set found = .Find(tbsrch4, 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 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 = TrueEnd SubPrivate 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 = FalseEnd SubPrivate 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 WithEnd SubPrivate Sub UserForm_Click() </code></pre>[COLOR=#333333]End Sub
[/COLOR]
Last edited:
