VBA Search Code

[Arek]

Good Afternoon,

I am trying to modify the following code to only search one sheet and not the whole workbook(remove the loop and check sheet2 only). I am not very savvy with VBA any help would be appreciated.

Public Sub FindTextFromCell()
'Run from standard module, like: Module1.
Sheet3.Cells.Clear
'Clear prevoius search result
Dim ws As Worksheet, Found As Range, rngNm As String
Dim myText As String, FirstAddress As String, thisLoc As String
Dim AddressStr As String, foundNum As Integer
myText = Sheets("Entry Form").Range("A10").Value
'Location of search box
If myText = "" Then Exit Sub
For Each ws In ThisWorkbook.Worksheets
With ws
Set Found = .UsedRange.Find(What:=myText, LookIn:=xlValues, MatchCase:=False)
If Not Found Is Nothing Then
FirstAddress = Found.Address
Do
If .Name = "Search Result" Then GoTo myNext
If .Name <> "Search Result" Then _
Found.EntireRow.Copy _
Destination:=Worksheets("Search Result").Range("A65536").End(xlUp).Offset(1, 0)
'The results go into the sheet listed above
Set Found = .UsedRange.FindNext(Found)
Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
End With
myNext:
Next ws
End Sub

 

[AlphaFrog]

Change the sheet name in red to the name of the sheet you want to search.

Public Sub FindTextFromCell()
    'Run from standard module, like: Module1.
    'Clear prevoius search result
    Dim Found As Range, r As Long
    Dim myText As String, FirstAddress As String
    myText = Sheets("Entry Form").Range("A10").Value
    'Location of search box
    If myText = "" Then Exit Sub
    With Sheets("[COLOR="Red"]Sheet2[/COLOR]")
        Set Found = .UsedRange.Find(What:=myText, LookIn:=xlValues, MatchCase:=False)
        If Not Found Is Nothing Then
            FirstAddress = Found.Address
            Do
                Found.EntireRow.Copy _
                Destination:=Worksheets("Search Result").Range("A65536").End(xlUp).Offset(1)
                r = r + 1
                'The results go into the sheet listed above
                Set Found = .UsedRange.FindNext(Found)
            Loop While Found.Address <> FirstAddress
            MsgBox r & " rows copied.", vbInformation, "Copy Complete"
        Else
            MsgBox "No match found for " & myText, vbExclamation, "No Match"
        End If
    End With
End Sub

 

[Fizzyfish]

Try this code:

Public Sub FindTextFromCell()
'Run from standard module, like: Module1.
Sheet3.Cells.Clear
'Clear prevoius search result
Dim ws As Worksheet, Found As Range, rngNm As String
Dim myText As String, FirstAddress As String, thisLoc As String
Dim AddressStr As String, foundNum As Integer
SET ws = ActiveWorkbook.Worksheets("Sheet2")
myText = Sheets("Entry Form").Range("A10").Value
'Location of search box
If myText = "" Then Exit Sub
'REMOVED: For Each ws In ThisWorkbook.Worksheets
With ws
Set Found = .UsedRange.Find(What:=myText, LookIn:=xlValues, MatchCase:=False)
If Not Found Is Nothing Then
FirstAddress = Found.Address
Do
If .Name = "Search Result" Then GoTo myNext
If .Name <> "Search Result" Then _
Found.EntireRow.Copy _
Destination:=Worksheets("Search Result").Range("A65536").End(xlUp).Offset(1, 0)
'The results go into the sheet listed above
Set Found = .UsedRange.FindNext(Found)
Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
End With
myNext:
'REMOVED: Next ws
End Sub

 

[Arek]

Fizzy that worked great ! Thanks!

 

[Fizzyfish]

You're welcome!

 

[Arek]

I now have a new use for the code but need more modification! The code needs to check column C for MyText only.

Public Sub FindTextFromCell()
'Run from standard module, like: Module1.
Sheet17.Cells.Clear
'Clear prevoius search result
Dim ws As Worksheet, Found As Range, rngNm As String
Dim myText As String, FirstAddress As String, thisLoc As String
Dim AddressStr As String, foundNum As Integer
myText = Sheets("Dashboard").Range("C2").Value
'Location of search box
If myText = "" Then Exit Sub
For Each ws In ThisWorkbook.Worksheets
With ws
Set Found = .UsedRange.Find(What:=myText, LookIn:=xlValues, MatchCase:=False)
If Not Found Is Nothing Then
FirstAddress = Found.Address
Do
If .Name = "In Progress" Then GoTo myNext
If .Name <> "In Progress" Then _
Found.EntireRow.Copy _
Destination:=Worksheets("In Progress").Range("A65536").End(xlUp).Offset(1, 0)
'The results go into the sheet listed above
Set Found = .UsedRange.FindNext(Found)
Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
End With
myNext:
Next ws
End Sub