Ah of course, you don't want to search the destination sheet

Set DestSht = WorkSheets("Sheet1")
' code

For Each Sh In ActiveWorkbook.Worksheets
If Sh.Name < DestSht.Name Then
' code

End If
Next

You might want to first delete all previous entries in the destination
sheet, or include some code to start NewRow below the last entry.

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hey Peter, your code worked fine. But a problem!

The code displayed 5000 rows with the same entry in the Set DestSht =
Sheets("Sheet1"). How to avoid the Sheet 1?


"Peter T" wrote:

Private Sub cmdbtn1_Click()
Dim NewRow As Long
Dim firstAddress As String, sWhat As String
Dim sAddr As String, sMsg As String
Dim rFound As Range
Dim Sh As Worksheet
Dim FoundIt As Boolean
Dim DestSht As Worksheet

Set DestSht = Sheets("Sheet1")
NewRow = 12

sAddr = "B4: B5000"
'e = "B1:B5000"
Let sWhat = txtbx1.Value

If Len(sWhat) = 2 Then
sWhat = "*" & sWhat & "*"
ElseIf Len(sWhat) < 2 Then
If Len(sWhat) = 1 Then
sMsg = "You only enered one character"
Else
sMsg = "You haven't typed anything in the Search Box" & _
vbNewLine & "Contact:US"
End If
MsgBox sMsg, , "Help!!"
Exit Sub
End If

For Each Sh In ActiveWorkbook.Worksheets
With Sh.Range(sAddr)

Set rFound = .Find(sWhat, LookIn:=xlValues, LookAt:=xlWhole,
_
SearchOrder:=xlByRows)

If Not rFound Is Nothing Then
firstAddress = rFound.Address
Do
DestSht.Range("B" & NewRow & ":H" & NewRow).Value = _
rFound.Resize(, 7).Value
DestSht.Range("A" & NewRow) = Sh.Name
NewRow = NewRow + 1
FoundIt = True
Set rFound = .FindNext(after:=rFound)
Loop While Not rFound Is Nothing And _
rFound.Address < firstAddress
End If
End With

Next
If FoundIt = False Then
MsgBox "Data not found!!", , "Sorry!!"
End If

End Sub

Regards,
Peter T


"Rose Tamang 2001" wrote in
message ...
Dear Friends,

I've this code seaching sheets for a specific word and display it.
At this time the code accepts only a correct spellings. If wrong a msg
box
is displayed. I want, that code should accept any two english alphabets
typed
in the text box and display the result with words that contains two
letters

Any idea!! Help!!

Private Sub cmdbtn1_Click()
Dim Sh As Worksheet
Dim FoundIt As Boolean
Set DestSht = Sheets("Main")
NewRow = 12

d = "B4: B5000"
'e = "B1:B5000"
Let c = txtbx1.Value

For Each Sh In ActiveWorkbook.Worksheets
With Sh.Range(d)
Set b = .Find(c, LookIn:=xlValues, LookAt:=xlWhole,
SearchOrder:=xlByRows)

If c = "" Then
MsgBox "You haven't typed anything in the Search Box" & vbNewLine
&
"Contact:US", , "Help!!"
Exit Sub



ElseIf Not b Is Nothing Then
firstAddress = b.Address
lbl1.Caption = b




Do
Sh.Range("B" & b.Row & ":H" & b.Row).Copy
Destination:=DestSht.Range("B" &
NewRow)
DestSht.Range("A" & NewRow) = Sh.Name
NewRow = NewRow + 1
FoundIt = True
Set b = .FindNext(after:=b)
Loop While Not b Is Nothing And b.Address < firstAddress
End If
End With




Next
If FoundIt = False Then
MsgBox "Data not found!!", , "Sorry!!"
End If

End Sub
Private Sub cmdbtn2_Click()
lbl1.Caption = ""
txtbx1.Value = ""
LastRow = Rows.Count
Rows("12:" & LastRow).Delete

End Sub


.