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
