Excel VBAの質問。行のコピーと削除について

質問

Excel VBAでSheet1のD列に「処分」という文字が入力されていたら、その行を
Sheet2へコピーし、Sheet1のその行を削除するというマクロを作成したいのですが、
削除をさせる位置が悪いのか件数が合いません。
下の例では、Sheet1のD列には「処分」という文字が入力されている行が3行あります。
Sheet1の1,3,4行目をSheet2へコピーした後にSheet1の1,3,4行目を削除して
行を上に詰めたいのです。
ネットで検索したり、書籍を読みながらここまで作成したのですが、どうしてもうまくいきません。
大変困っております。どうか、間違えている箇所を教えてください。よろしくお願いします。

A B C D E F
-|-----------------------------------------
1| 1 03/01 時計 処分 倉庫 特になし
2| 2 03/05 電話 保留　 倉庫 連絡済
3| 3 03/10 紙袋　処分 売店　 使用済み
4| 4 03/11 電池　処分　 倉庫 空白
5| 5 03/12 時計　保留　 売店　 空白

Private Sub cmdmSyobun_Click()

Dim SyobunWord As String
Dim gyou As Long
Dim word As String
Dim LastRow As Long
Dim hantei As Integer
Dim count As Integer
Dim baseB As Workbook
Dim baseS As Worksheet

SyobunWord = "処分"

Set baseB = ThisWorkbook
Set baseS = baseB.Worksheets("Sheet1")
baseS.Activate

With Worksheets("Sheet1")

hantei = MsgBox("「処分」データを移動しますか？", vbYesNo)

Select Case hantei
Case vbYes
count = 0
gyou = 2
LastRow = baseS.Cells(Rows.count, 1).End(xlUp).Row

Do While Cells(gyou, 4) <> ""
word = Cells(gyou, 4)
If InStr(word, MoveWord) >= 1 Then
count = count + 1
Rows(gyou).Copy Worksheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Offset(1, 0)
Rows(gyou).Delete Shift:=xlShiftUp

End If
gyou = gyou + 1
Loop

Case vbNo
MsgBox "「処分」データは移動されませんでした。"

End Select

End With

MsgBox MoveWord & "は、" & count & "件でした。"

End Sub

回答No.1

kybo · ベストアンサー

間違えているところ

最初に
SyobunWord = "処分"
としているのに、

If InStr(word, MoveWord) >= 1 Then
となっている。

If InStr(word, SyobunWord) >= 1 Then

とすべき。

あと、コピーしたものを消していって上に詰めていくので、下から検索しないとだめです。
例えば、上からすると1番目で見つかって削除されたら、2番目にあった行が1行目に移動してしまいます。なので、ずれます。

ということで、以下の様になります。

Private Sub cmdmSyobun_Click()
Dim SyobunWord As String
Dim gyou As Long
Dim word As String
Dim LastRow As Long
Dim hantei As Integer
Dim count As Integer
Dim baseB As Workbook
Dim baseS As Worksheet
SyobunWord = "処分"
Set baseB = ThisWorkbook
Set baseS = baseB.Worksheets("Sheet1")
baseS.Activate
With Worksheets("Sheet1")
hantei = MsgBox("「処分」データを移動しますか？", vbYesNo)
Select Case hantei
Case vbYes
count = 0
gyou = Range("A" & Rows.count).End(xlUp).Row
LastRow = baseS.Cells(Rows.count, 1).End(xlUp).Row
Do While Cells(gyou, 4) <> ""
word = Cells(gyou, 4)

If InStr(1, word, SyobunWord) >= 1 Then
count = count + 1
Rows(gyou).Copy Worksheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Offset(1, 0)
Rows(gyou).Delete Shift:=xlShiftUp
End If
gyou = gyou - 1
If gyou = 0 Then Exit Do
Loop
Case vbNo
MsgBox "「処分」データは移動されませんでした。"
End Select
End With
MsgBox MoveWord & "は、" & count & "件でした。"
End Sub

お礼

早速教えて頂きましてありがとうございました。
ネットで調べたときに、下から検索するというのを見つけ自分なりに考えてコードを書いてみたのですが、どうもうまく動かずでした。
教えていただき、改めてコードを見て、動きを確認し、希望通りの動きをしたのでもう感動モノでした。
本当にありがとうございました。他にも似たようなことをしたい箇所がありますので、このコードを元にまた自分で考えてチャレンジしたいと思いました。本当に助かりました。ありがとうございました。