ExcelBanter - Search a sheet for a word

ExcelBanter (https://www.excelbanter.com/)

- Excel Programming (https://www.excelbanter.com/excel-programming/)

- - Search a sheet for a word (https://www.excelbanter.com/excel-programming/442385-search-sheet-word.html)

Rose Tamang 2001

Search a sheet for a word

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

Bob Umlas, Excel MVP

Search a sheet for a word

Sub Findit()
Dim search As String, sh As Worksheet, orig As Worksheet
search = InputBox("Enter characters to find")
If search = "" Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
Set orig = ActiveSheet
For Each sh In Sheets
sh.Activate
Err.Clear
Cells.Find(search, LookIn:=xlFormulas, LookAt:=xlPart).Select
If Err.Number = 0 Then Exit Sub
Next
orig.Activate
Application.ScreenUpdating = True
MsgBox search & " not found."
End Sub

"Rose Tamang 2001" wrote:

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

Peter T

Search a sheet for a word

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

Rose Tamang 2001

Search a sheet for a word

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

.

Peter T

Search a sheet for a word

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

.

Rose Tamang 2001

Search a sheet for a word

Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in the main
sheet??

"Peter T" wrote:

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

.

.

Peter T

Search a sheet for a word

I'm not sure what you consider is the main sheet. Assuming txtbx1 is an
ActiveX textbox maybe you can adapt the following to your needs -

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Sheet1").OLEObjects("Textbox1")
ole.Parent.Activate
ole.Activate

End Sub

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in the main
sheet??

"Peter T" wrote:

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

.

.

Rose Tamang 2001

Search a sheet for a word

Hey Pete,

Exactly, I have named the sheet1 as 'Main'
The code didn't work. I don't see the cursor blink in the txtbx1

"Peter T" wrote:

I'm not sure what you consider is the main sheet. Assuming txtbx1 is an
ActiveX textbox maybe you can adapt the following to your needs -

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Sheet1").OLEObjects("Textbox1")
ole.Parent.Activate
ole.Activate

End Sub

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in the main
sheet??

"Peter T" wrote:

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

.

.

.

Rose Tamang 2001

Search a sheet for a word

Peter T

Search a sheet for a word

When you say the code didn't work try and explain what you mean. Did it
error, if so one what line, what error message.

The code should work, did you adjust all the names correctly. Start with a
simple macro exactly as posted. Put am ActiveX Textbox named "Textbox1" on
"Sheet1" of the activeworkbook. Select a cell on sheet1. Activate a
different sheet. Run the macro.

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hey Pete,

Exactly, I have named the sheet1 as 'Main'
The code didn't work. I don't see the cursor blink in the txtbx1

"Peter T" wrote:

I'm not sure what you consider is the main sheet. Assuming txtbx1 is an
ActiveX textbox maybe you can adapt the following to your needs -

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Sheet1").OLEObjects("Textbox1")
ole.Parent.Activate
ole.Activate

End Sub

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in the
main
sheet??

"Peter T" wrote:

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

.

.

.

Rose Tamang 2001

Search a sheet for a word

hi, Pete,

Can you tell me if it's possible to protect the main sheet. I tried once but
the controls in the protected sheet didn't respond. Any idea!!!

"Peter T" wrote:

I'm not sure what you consider is the main sheet. Assuming txtbx1 is an
ActiveX textbox maybe you can adapt the following to your needs -

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Sheet1").OLEObjects("Textbox1")
ole.Parent.Activate
ole.Activate

End Sub

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in the main
sheet??

"Peter T" wrote:

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

.

.

.

Rose Tamang 2001

Search a sheet for a word

Rose Tamang 2001

Search a sheet for a word

I modified only the names in the code like this:

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Main").OLEObjects("txtbx1")
ole.Parent.Activate
ole.Activate

End Sub

Sorry!! The code showed no response!!
I mean the cursor didn't blink in the txtbx1

"Peter T" wrote:

When you say the code didn't work try and explain what you mean. Did it
error, if so one what line, what error message.

The code should work, did you adjust all the names correctly. Start with a
simple macro exactly as posted. Put am ActiveX Textbox named "Textbox1" on
"Sheet1" of the activeworkbook. Select a cell on sheet1. Activate a
different sheet. Run the macro.

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hey Pete,

Exactly, I have named the sheet1 as 'Main'
The code didn't work. I don't see the cursor blink in the txtbx1

"Peter T" wrote:

I'm not sure what you consider is the main sheet. Assuming txtbx1 is an
ActiveX textbox maybe you can adapt the following to your needs -

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Sheet1").OLEObjects("Textbox1")
ole.Parent.Activate
ole.Activate

End Sub

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in the
main
sheet??

"Peter T" wrote:

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

.

.

.

.

Rose Tamang 2001

Search a sheet for a word

Peter T

Search a sheet for a word

The code works fine for me so there must be some simple explanation for it
not working your end. Assuming you started on a different sheet, Does Sheet1
(or your Main) activate after running the code. If you are running the code
from the VBE you need to switch to Excel and ensure it is active, click the
main Excel caption to be sure.

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
I modified only the names in the code like this:

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Main").OLEObjects("txtbx1")
ole.Parent.Activate
ole.Activate

End Sub

Sorry!! The code showed no response!!
I mean the cursor didn't blink in the txtbx1

"Peter T" wrote:

When you say the code didn't work try and explain what you mean. Did it
error, if so one what line, what error message.

The code should work, did you adjust all the names correctly. Start with
a
simple macro exactly as posted. Put am ActiveX Textbox named "Textbox1"
on
"Sheet1" of the activeworkbook. Select a cell on sheet1. Activate a
different sheet. Run the macro.

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hey Pete,

Exactly, I have named the sheet1 as 'Main'
The code didn't work. I don't see the cursor blink in the txtbx1

"Peter T" wrote:

I'm not sure what you consider is the main sheet. Assuming txtbx1 is
an
ActiveX textbox maybe you can adapt the following to your needs -

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Sheet1").OLEObjects("Textbox1")
ole.Parent.Activate
ole.Activate

End Sub

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in
the
main
sheet??

"Peter T" wrote:

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

.

.

.

.

Peter T

Search a sheet for a word

In 2007, Review, (Changes) Protect Sheet
In 97-2003, Tools, Protection, Protect Sheet

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
hi, Pete,

Can you tell me if it's possible to protect the main sheet. I tried once
but
the controls in the protected sheet didn't respond. Any idea!!!

"Peter T" wrote:

I'm not sure what you consider is the main sheet. Assuming txtbx1 is an
ActiveX textbox maybe you can adapt the following to your needs -

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Sheet1").OLEObjects("Textbox1")
ole.Parent.Activate
ole.Activate

End Sub

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in the
main
sheet??

"Peter T" wrote:

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

.

.

.

Rose Tamang 2001

Search a sheet for a word

I protected the sheet! My concern is that the controls in the sheet didn't
responded.

"Peter T" wrote:

In 2007, Review, (Changes) Protect Sheet
In 97-2003, Tools, Protection, Protect Sheet

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
hi, Pete,

Can you tell me if it's possible to protect the main sheet. I tried once
but
the controls in the protected sheet didn't respond. Any idea!!!

"Peter T" wrote:

I'm not sure what you consider is the main sheet. Assuming txtbx1 is an
ActiveX textbox maybe you can adapt the following to your needs -

Sub test()
Dim ole As OLEObject
Set ole = Worksheets("Sheet1").OLEObjects("Textbox1")
ole.Parent.Activate
ole.Activate

End Sub

Regards,
Peter T

"Rose Tamang 2001" wrote in
message ...
Hi, Peter,

It worked fine!! Can you please help me to set focus on txtbx1 in the
main
sheet??

"Peter T" wrote:

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

.

.

.

.

Rose Tamang 2001

Search a sheet for a word

All times are GMT +1. The time now is 10:34 AM.