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

質問

通達番号 　発効日 　　　　通達名称 　　発行部署　　
(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.5

imogasi

まず考えられるのは
「通達名称」列（項目）で営業が見つかったとき、別シートに書き出し、
「発行部署」列（項目）で営業が見つかったとき、別シートに書き出ししていませんか。＝＝＞どうもこれではないらしい。
ーー
ロジックは
「通達名称」列で見つからないと脱出（「発行部署」で見つかっても条件満たさず）
見つかったときは「発行部署」列をチェック
見つかったときは別シートに書き指し
見つからないときは脱出
ーー
検索セル＝列のセルを限定して検索しないとダメで、質問ではそのセルより先のセル全部を検索対象になっていませんか。それであるなしを判断するとではそのセルより先のセルの（別行でも）通達列と営業列のどちらか一方でも、「営業」があれば、条件を満たしてしまう。
ーー
本件では、各行の２つのセルの問題なので
Findメソッド（xlPart)よりINSTR関数がお勧めです。
aaは本件では"営業"。
Sub test02()
For i = 1 To 4
p = InStr(Cells(i, 1), "aa")
If p <> 0 Then
MsgBox i & "行目　aa含む"
End If
Next i
End Sub
Findは判定にもIs Nothing の知識が要って初心者向けではない。
使わなければならない場合が多々あるが、本件は１行の２セル限定で考えるべきなので。
ーー
Like演算子で
Sub test01()
For i = 1 To 4
If Cells(i, 1) Like "*aa*" Then
MsgBox i & "行目　aa含む"
End If
Next i
End Sub
のような方法もある。
例データ（A列）
aass
qqaaw
sdaws
sdfadaa

回答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

回答No.3

watabe007

シートの1行目が項目名でデータは2行目からとしています。
参考程度に
Private Sub 検索_Click()
　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Dim rng As Range, myR As Long
　　Dim myStr As String

　　myStr = TextBox1.Value
　　If myStr = "" Then
　　　　MsgBox "検索する語句を入れてください。"
　　　　Exit Sub
　　End If
　　Set ws1 = Worksheets(2)
　　Set ws2 = Worksheets(3)
　　myR = 2
　　For Each rng In ws1.Range("A2", ws1.Cells(Rows.Count, 1).End(xlUp)).Resize(, 4).Rows
　　　　If Application.CountIf(rng, "*" & myStr & "*") > 0 Then
　　　　　　rng.Copy ws2.Cells(myR, 1)
　　　　　　ws2.Cells(myR, 1).Value = myR - 1
　　　　　　myR = myR + 1
　　　　End If
　　Next
　　If myR = 2 Then
　　　　MsgBox "データは見つかりませんでした"
　　Else
　　　　MsgBox "データは、" & myR - 2 & "件、見つかりました"
　　End If
End Sub

回答No.2

watabe007

>別シートへは２行のみ（(1)と(3)）表示したいところ、４行表示されてしまいます。
表示される以前にエラーがでて動かないでしょう
>With ws1.Range(Cells(3, 1), Cells(100, 10))
↓
With ws1.Range(ws1.Cells(3, 1), ws1.Cells(100, 10))

回答No.1

n-jun

ざっと見た限りですが、

＞Set rng = .FindNext(rng) '連続検索
を
Set rng = .FindNext(Cells(rng.Row, 10)) '連続検索
とする。
⇒見つかったセルの同行の１０列目の次を検索開始位置としてしまう。

と言うのもありですかね。