search macro retrieving all occurances as well as partial matches

wCJanssen

New Member
Joined
Feb 22, 2009
Messages
24
Hi there<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
<o:p></o:p>
I'm working on a database for a Dutch nursing home, which - if I ever get it to work properly - will eventually contain data on several hundred people. To help users navigate through the records, I created an index-sheet listing all sheets in the workbook, with every sheet representing a single resident. However, I'd like to add a searchbox to this sheet, to simplify matters even further. I found a macro that will search the sheet for a user-defined keyword, but it stops searching after finding the first match. A second macro I got to work does return all instances of a given phrase, but the keyword is case sensitive and it doesn’t retrieve ‘partial matches’. That is: when the user is looking for the records of, say, resident “B Gates” and types “Gates”, nothing comes up – you need to know the residents initials to retrieve his or her records. What I’d like of course is a macro that combines the best of both these codes (returns partial matches and returns all occurrences of the keyword) and I’d be very happy if any one of you could help me out here. The macro’s I have tried so far are as follows: <o:p></o:p>
<o:p></o:p>
<o:p></o:p>
Sub searchmacro1()<o:p></o:p>
Dim vFound As Range<o:p></o:p>
On Error GoTo ErrorHandle<o:p></o:p>
Set vFound = Cells.Find(What:=InputBox("Please enter resident name"), After:=Cells(1, 10), _<o:p></o:p>
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _<o:p></o:p>
MatchCase:=False, SearchFormat:=False)<o:p></o:p>
If Not vFound Is Nothing Then<o:p></o:p>
Rows(vFound.Row).Copy Destination:= _<o:p></o:p>
ActiveWorkbook.Sheets("002Inhoudsopgave").Range("A1")<o:p></o:p>
Exit Sub<o:p></o:p>
Else<o:p></o:p>
MsgBox ("Your search did not yield any results")<o:p></o:p>
Exit Sub<o:p></o:p>
End If<o:p></o:p>
ErrorHandle:<o:p></o:p>
If Err.Number = 9 Then<o:p></o:p>
MsgBox ("Error")<o:p></o:p>
Else<o:p></o:p>
MsgBox (Err.Description)<o:p></o:p>
End If <o:p></o:p>
End Sub
----------------------------------------------------------------------------------------------------------------------------
Sub Searchmacro2 ()<o:p></o:p>
Dim LSearchRow As Integer<o:p></o:p>
Dim LCopyToRow As Integer<o:p></o:p>
Dim LSearchValue As String<o:p></o:p>
On Error GoTo Err_Execute<o:p></o:p>
LSearchValue = InputBox("please enter resident name", "Enter name")<o:p></o:p>
Rows("2:9").Select<o:p></o:p>
Selection.ClearContents<o:p></o:p>
LSearchRow = 12<o:p></o:p>
LCopyToRow = 2<o:p></o:p>
While Len(Range("A" & CStr(LSearchRow)).Value) > 0<o:p></o:p>
If Range("A" & CStr(LSearchRow)).Value = LSearchValue Then<o:p></o:p>
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select<o:p></o:p>
Selection.Copy<o:p></o:p>
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select<o:p></o:p>
ActiveSheet.Paste<o:p></o:p>
LCopyToRow = LCopyToRow + 1<o:p></o:p>
Sheets("002Inhoudsopgave").Select<o:p></o:p>
End If<o:p></o:p>
LSearchRow = LSearchRow + 1<o:p></o:p>
Wend<o:p></o:p>
Application.CutCopyMode = True<o:p></o:p>
Range("A2").Select<o:p></o:p>
MsgBox "All matching data has been copied."<o:p></o:p>
Exit Sub<o:p></o:p>
Err_Execute:<o:p></o:p>
MsgBox "An error occurred."<o:p></o:p>
End Sub
----------------------------------------------------------------------------------------------------------------------------
Thanks in advance
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Once you have located instances, what would you like to do ?

List their location in a seperate sheet?

display the location in a message box?

or something else ?
 
Upvote 0
See if this does what you need:
Code:
Sub searchmacro1()
   Dim vFound As Range, rngOutput As Range
   Dim strFirstAddress As String
   On Error GoTo ErrorHandle
   Set vFound = Cells.Find(What:=InputBox("Please enter resident name"), After:=Cells(1, 10), _
   LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
   MatchCase:=False, SearchFormat:=False)
   If Not vFound Is Nothing Then
      strFirstAddress = vFound.Address
      Set rngOutput = ActiveWorkbook.Sheets("002Inhoudsopgave").Range("A1")
      Do
         vFound.EntireRow.Copy Destination:=rngOutput
         Set rngOutput = rngOutput.Offset(1, 0)
         Set vFound = Cells.FindNext(vFound)
      Loop Until vFound.Address = strFirstAddress
   Else
      MsgBox ("Your search did not yield any results")
   End If
   Exit Sub
ErrorHandle:
   If Err.Number = 9 Then
      MsgBox ("Error")
   Else
      MsgBox (Err.Description)
   End If
End Sub
 
Upvote 0
Once you have located instances, what would you like to do ?

List their location in a seperate sheet?

display the location in a message box?

or something else ?
Sorry, I forgot to mention that - once all instances have been located, I'd like to copy the matching rows either to a different sheet or to the top rows of the active sheet. thanks for your reply.
 
Upvote 0
See if this does what you need:
Code:
Sub searchmacro1()
   Dim vFound As Range, rngOutput As Range
   Dim strFirstAddress As String
   On Error GoTo ErrorHandle
   Set vFound = Cells.Find(What:=InputBox("Please enter resident name"), After:=Cells(1, 10), _
   LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
   MatchCase:=False, SearchFormat:=False)
   If Not vFound Is Nothing Then
      strFirstAddress = vFound.Address
      Set rngOutput = ActiveWorkbook.Sheets("002Inhoudsopgave").Range("A1")
      Do
         vFound.EntireRow.Copy Destination:=rngOutput
         Set rngOutput = rngOutput.Offset(1, 0)
         Set vFound = Cells.FindNext(vFound)
      Loop Until vFound.Address = strFirstAddress
   Else
      MsgBox ("Your search did not yield any results")
   End If
   Exit Sub
ErrorHandle:
   If Err.Number = 9 Then
      MsgBox ("Error")
   Else
      MsgBox (Err.Description)
   End If
End Sub
Thanks for your (very) fast reply; and it turned out to be quite valuable as well - the macro works perfect! Thanks a lot, I've been struggling with this problem for quite some time.
 
Upvote 0

Forum statistics

Threads
1,213,520
Messages
6,114,101
Members
448,548
Latest member
harryls

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