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

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

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

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


.

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


.

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


.



.

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


.



.