エクセル、VBAで任意の文字が入った行を別のシートにコピーして削除

エクセルにてVBAで任意の文字が入った行を別のシートにコピーし、元のシートの行を削除させようとしています。
VBAをよく理解していませんがネットで調べた情報を元に以下のようなコードを書きました。

Sheet1にtargetsの野菜名があれば、新たに作成した野菜のシートにその行をコピーし、Sheet1の当該行を削除
という想定で、一応は動作するのですが、20行以上ある場合は一度の実行では全てコピー削除ができす、何回(2～3回)か実行しなければ全てコピー削除ができません。
1回の実行で全て完了させるにはどのようにすれば良いでのでしょうか。
尚、Sheet1の野菜名は特定の2つの列(品名と備考)にしか存在しません。
素人故、変な部分もあると思いますが、ここが問題だという部分をご指摘いただければ幸いです。
以上、よろしくお願いします。

Sub Vegetables()
'検索Sheet
Const Read_Sheet = "Sheet1"
'書込みSheet
Const Write_Sheet = "やさい"
Dim i As Long      '行番号
Dim Column1  As Range
Dim Column2  As Range
Dim str1, Hinmei, Bikou
Dim LastRow As Long
Dim ws As Worksheet, flag As Boolean

'列番号取得(やさいの名前がこれらの列に入っている為)
Hinmei = Rows(1).Find("品名").Column
Bikou = Rows(1).Find("備考").Column

Dim targets
targets = Array("人参", "ピーマン", "南瓜", "トマト", "レタス", "キャベツ", "胡瓜", "大根", "ほうれん草", "トウモロコシ")

'取りこぼしが無いようヒットした対象の文字を赤色にする
For Each c In ActiveSheet.UsedRange
    For Each target In targets
        If InStrRev(c, target) > 0 Then c.Characters(InStrRev(c, target), Len(target)).Font.ColorIndex = 3
    Next
Next
Application.ScreenUpdating = True

'やさいのシート作成
For Each ws In Worksheets
   If ws.Hinmei = "やさい" Then flag = True
Next ws
If flag = True Then
Else
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Hinmei = "やさい"
End If

Set xlSh = Worksheets(1)
Sheets(Read_Sheet).Select
’１行目は見出しなので2行目からループ実行
    For i = 2 To xlSh.Range("A1").End(xlDown).Row
        For Each str1 In targets
        Set Column1 = xlSh.Cells(i, Hinmei)
        Set Column2 = xlSh.Cells(i, Bikou)
            If InStr(1, Column1, str1, vbBinaryCompare) > 0 Or InStr(1, Column2, str1, vbBinaryCompare) > 0 Then
                Application.CutCopyMode = True
                Sheets(Read_Sheet).Rows(i).Copy
                With Worksheets(Write_Sheet)
                LastRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                End With
                Sheets(Write_Sheet).Rows(LastRow).PasteSpecial
                Sheets(Read_Sheet).Rows(i).Delete
            End If
        Next str1
    Next i
End Sub