LinkBack URL
About LinkBacks
Hi,
I am a novice to VBA but I am trying to set up a search box for a database.
I want to create 5 search boxes for key skills. When search is pressed I would like the search to look through the database data and copy all of the people from the database and place them onto a new sheet.
I have found and adapted slightly some other code where it brings up a search box when you start the macro and then brings up another box after and another box after until you have entered all 5 skills.
It does the same thing but it's not ideal.
Can anybody help?!
Thanks,
jphilcox
The code that I use is below (Note: the below code only does two iterations of the search):
Sub searchbox()
'Standard module code, like: Module1.
'Find my data and list found rows in report!
Dim rngData As Object
Dim strDataShtNm$, strReportShtNm$, strMySearch$, strMyCell$
Dim lngLstDatCol&, lngLstDatRow&, lngReportLstRow&, lngMyFoundCnt&
On Error GoTo myEnd
'*******************************************************************************
strDataShtNm = "Sheet2" 'This is the name of the sheet that has the data!
strReportShtNm = "Sheet1" 'This is the name of the report to sheet!
'*******************************************************************************
Sheets(strReportShtNm).Select
Application.ScreenUpdating = False
'Define data sheet's data range!
Sheets(strDataShtNm).Select
With ActiveSheet.UsedRange
lngLstDatRow = .Rows.Count + .Row - 1
lngLstDatCol = .Columns.Count + .Column - 1
End With
Set rngData = ActiveSheet.range(Cells(1, 1), Cells(lngLstDatRow, lngLstDatCol))
'Get the string to search for!
strMySearch = InputBox("Enter what to search for, below:" & vbLf & vbLf & _
"Note: The search is case sensitive!", _
Space(3) & "Find All", _
"")
'NOTE: "Find All" is the name of the search box
'Do the search!
For Each Cell In rngData
strMyCell = Cell.Value
'If found then list entire row!
If strMyCell = strMySearch Then
lngMyFoundCnt = lngMyFoundCnt + 1
ActiveSheet.Rows(Cell.Row & ":" & Cell.Row).Copy
With Sheets(strReportShtNm)
'Paste found data's row!
lngReportLstRow = .UsedRange.Rows.Count + .UsedRange.Row
ActiveSheet.Paste Destination:=.range("A" & lngReportLstRow).EntireRow
End With
End If
Next Cell
myEnd:
'Do clean-up!
Application.ScreenUpdating = True
Application.CutCopyMode = False
Sheets(strReportShtNm).Select
'If not found then notify!
If lngMyFoundCnt = 0 Then
MsgBox """" & strMySearch & """" & Space(3) & "Was not found!", _
vbCritical + vbOKOnly, _
Space(3) & "Not Found!"
End If
Sheets(strReportShtNm).Select
Rows("1:1").Select
Selection.ClearContents
Selection.delete Shift:=xlUp
'SECOND TIME AROUND
Dim rngData2 As Object
Dim strDataShtNm2$, strReportShtNm2$, strMySearch2$, strMyCell2$
Dim lngLstDatCol2&, lngLstDatRow2&, lngReportLstRow2&, lngMyFoundCnt2&
On Error GoTo myEnd
'*******************************************************************************
strDataShtNm2 = "Sheet1" 'This is the name of the sheet that has the data!
strReportShtNm2 = "Sheet3" 'This is the name of the report to sheet!
'*******************************************************************************
Sheets(strReportShtNm2).Select
Application.ScreenUpdating = False
'Define data sheet's data range!
Sheets(strDataShtNm2).Select
With ActiveSheet.UsedRange
lngLstDatRow2 = .Rows.Count + .Row - 1
lngLstDatCol2 = .Columns.Count + .Column - 1
End With
Set rngData2 = ActiveSheet.range(Cells(1, 1), Cells(lngLstDatRow2, lngLstDatCol2))
'Get the string to search for!
strMySearch2 = InputBox("Enter what to search for, below:" & vbLf & vbLf & _
"Note: The search is case sensitive!", _
Space(3) & "Find All", _
"")
'Do the search!
For Each Cell In rngData2
strMyCell2 = Cell.Value
'If found then list entire row!
If strMyCell2 = strMySearch2 Then
lngMyFoundCnt2 = lngMyFoundCnt2 + 1
ActiveSheet.Rows(Cell.Row & ":" & Cell.Row).Copy
With Sheets(strReportShtNm2)
'Paste found data's row!
lngReportLstRow2 = .UsedRange.Rows.Count + .UsedRange.Row
ActiveSheet.Paste Destination:=.range("A" & lngReportLstRow2).EntireRow
End With
End If
Next Cell
my2End:
'Do clean-up!
Application.ScreenUpdating = True
Application.CutCopyMode = False
Sheets(strReportShtNm2).Select
'If not found then notify!
If lngMyFoundCnt2 = 0 Then
MsgBox """" & strMySearch2 & """" & Space(3) & "Was not found!", _
vbCritical + vbOKOnly, _
Space(3) & "Not Found!"
End If
End Sub
Sub searchbox2()
'Standard module code, like: Module1.
'Find my data and list found rows in report!
Dim rngData As Object
Dim strDataShtNm$, strReportShtNm$, strMySearch$, strMyCell$
Dim lngLstDatCol&, lngLstDatRow&, lngReportLstRow&, lngMyFoundCnt&
On Error GoTo myEnd
'*******************************************************************************
strDataShtNm = "Sheet2" 'This is the name of the sheet that has the data!
strReportShtNm = "Sheet1" 'This is the name of the report to sheet!
'*******************************************************************************
Sheets(strReportShtNm).Select
Application.ScreenUpdating = False
'Define data sheet's data range!
Sheets(strDataShtNm).Select
With ActiveSheet.UsedRange
lngLstDatRow = .Rows.Count + .Row - 1
lngLstDatCol = .Columns.Count + .Column - 1
End With
Set rngData = ActiveSheet.range(Cells(1, 1), Cells(lngLstDatRow, lngLstDatCol))
'Get the string to search for!
strMySearch = InputBox("Enter what to search for, below:" & vbLf & vbLf & _
"Note: The search is case sensitive!", _
Space(3) & "Find All", _
"")
'Do the search!
For Each Cell In rngData
strMyCell = Cell.Value
'If found then list entire row!
If strMyCell = strMySearch Then
lngMyFoundCnt = lngMyFoundCnt + 1
ActiveSheet.Rows(Cell.Row & ":" & Cell.Row).Copy
With Sheets(strReportShtNm)
'Paste found data's row!
lngReportLstRow = .UsedRange.Rows.Count + .UsedRange.Row
ActiveSheet.Paste Destination:=.range("A" & lngReportLstRow).EntireRow
End With
End If
Next Cell
myEnd:
'Do clean-up!
Application.ScreenUpdating = True
Application.CutCopyMode = False
Sheets(strReportShtNm).Select
'If not found then notify!
If lngMyFoundCnt = 0 Then
MsgBox """" & strMySearch & """" & Space(3) & "Was not found!", _
vbCritical + vbOKOnly, _
Space(3) & "Not Found!"
End If
Sheets(strReportShtNm).Select
Rows("1:1").Select
Selection.ClearContents
Selection.delete Shift:=xlUp
'SECOND TIME AROUND
Dim rngData2 As Object
Dim strDataShtNm2$, strReportShtNm2$, strMySearch2$, strMyCell2$
Dim lngLstDatCol2&, lngLstDatRow2&, lngReportLstRow2&, lngMyFoundCnt2&
On Error GoTo myEnd
'*******************************************************************************
strDataShtNm2 = "Sheet1" 'This is the name of the sheet that has the data!
strReportShtNm2 = "Sheet3" 'This is the name of the report to sheet!
'*******************************************************************************
Sheets(strReportShtNm2).Select
Application.ScreenUpdating = False
'Define data sheet's data range!
Sheets(strDataShtNm2).Select
With ActiveSheet.UsedRange
lngLstDatRow2 = .Rows.Count + .Row - 1
lngLstDatCol2 = .Columns.Count + .Column - 1
End With
Set rngData2 = ActiveSheet.range(Cells(1, 1), Cells(lngLstDatRow2, lngLstDatCol2))
'Get the string to search for!
strMySearch2 = InputBox("Enter what to search for, below:" & vbLf & vbLf & _
"Note: The search is case sensitive!", _
Space(3) & "Find All", _
"")
'Do the search!
For Each Cell In rngData2
strMyCell2 = Cell.Value
'If found then list entire row!
If strMyCell2 = strMySearch2 Then
lngMyFoundCnt2 = lngMyFoundCnt2 + 1
ActiveSheet.Rows(Cell.Row & ":" & Cell.Row).Copy
With Sheets(strReportShtNm2)
'Paste found data's row!
lngReportLstRow2 = .UsedRange.Rows.Count + .UsedRange.Row
ActiveSheet.Paste Destination:=.range("A" & lngReportLstRow2).EntireRow
End With
End If
Next Cell
my2End:
'Do clean-up!
Application.ScreenUpdating = True
Application.CutCopyMode = False
Sheets(strReportShtNm2).Select
'If not found then notify!
If lngMyFoundCnt2 = 0 Then
MsgBox """" & strMySearch2 & """" & Space(3) & "Was not found!", _
vbCritical + vbOKOnly, _
Space(3) & "Not Found!"
End If
End Sub
Register To Reply
Bookmarks