キーワード検索後、部分一致した行のみコピーする方法について

質問

通達番号 　発効日 　　　　通達名称 　　発行部署　　
(1)　2009001 2009年08月01日　営業推進１　　　営業部
(2)　2009002 2009年08月02日　予算通知１　　　経理部
(3)　2009003 2009年08月02日　営業先支援　　　営業部
(4)　2009004 2009年08月03日　人事異動 　　人事部 　　　

フォームを作成し、キーワード検索をし、部分一致した行のみ
別シートへコピーする仕組みを構築したいと考えております。
現在、下記コードを作成中です。
１行中に同じ用語が複数存在する場合（例：「営業」を検索）、
別シートへは２行のみ（(1)と(3)）表示したいところ、４行表示
されてしまいます。（(1)(1)と(3)(3)）というようになります。
どのようにコード変更すればよろしいでしょうか？

Option Explicit

Private Sub 検索_Click()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim myStr, ra, rr
Dim number As Integer
Dim cnt As Integer
Dim cntstart As Integer
Dim cntend As Integer
Dim endrows As Integer

myStr = TextBox1.Value
rr = 2
number = 0

If myStr = "" Then
MsgBox "検索する語句を入れてください。"
Exit Sub
End If

Set ws1 = Worksheets(2)
Set ws2 = Worksheets(3)
With ws1.Range(Cells(3, 1), Cells(100, 10))

Set rng = .Find(What:=myStr, LookAt:=xlPart, After:=.Cells(.Cells.Count))
If rng Is Nothing Then 'なかったら
MsgBox "データは見つかりませんでした"
Else 'あったら
ra = rng.Address '最初に見つかったセルアドレス

Do
rr = rr + 1 'カウント
rng.EntireRow.Copy Destination:=ws2.Cells(rr, 1) '行のコピペ
Set rng = .FindNext(rng) '連続検索
Loop While rng.Address <> ra '繰り返し
Set rng = Nothing
End If
End With

rr = rr - 2

If rr = 0 Then

Else

cntstart = 3
cntend = rr + 2

For cnt = cntstart To cntend

number = number + 1
Worksheets(3).Range("A" & cnt).Value = number

Next cnt

End If

MsgBox rr & "件を抽出しました。"
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

Private Sub 閉じる_Click()
UserForm1.Hide
End Sub

回答No.4

end-u

文字列が対象の場合、簡易的に[フィルタオプション]を使っても良いかもしれません。

Dim ws1　 As Worksheet
Dim ws2　 As Worksheet
Dim myStr As String

myStr = Me.TextBox1.Text
If myStr = "" Then
　　MsgBox "検索する語句を入れてください。"
　　Exit Sub
End If

Set ws1 = Worksheets(2)
Set ws2 = Worksheets(3)
ws2.UsedRange.Clear '■注意。ws2をクリアします。
ws1.Range("IV1").Value = "検索条件"
ws1.Range("IV2").Formula = "=COUNTIF(A2:J2,""*" & myStr & "*"")>0"
ws1.Range("A1").CurrentRegion.Resize(, 10) _
　　　　　　　 .AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　　 CriteriaRange:=ws1.Range("IV1:IV2"), _
　　　　　　　　　　　　　　　 CopyToRange:=ws2.Range("A1"), _
　　　　　　　　　　　　　　　 Unique:=False
ws1.Range("IV2").ClearContents
MsgBox ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row - 1 & "件を抽出しました。"

Set ws1 = Nothing
Set ws2 = Nothing

検索対象リストはws1.Range("A1").CurrentRegion.Resize(, 10)としてますので
適宜変更してください。

【参考】
[XL2002]複雑な検索条件を使用してリストデータを抽出する方法（「II. 計算検索条件」）
http://support.microsoft.com/kb/402757/ja