検索して別のシートの行を削除のしかた

現在出納帳を作成中です。入力はすべてuserformから行っており削除もuserformか行っております。
しかし出納帳だけは削除したい行をクリックすると削除のuserformが表示されボタンを押すと実行されます。ボタンを押したら削除userformの日付、費目、内容が完全一致したら（出納帳）別シートの該当する行も一緒に削除できればと思います。別シートは科目ごとに計14シートあります。

（例）1、出納帳で削除したい行を選択
　　　２、userformで内容を確認し削除を実行
　　　 3、関連する別のシートの行も自動削除

いろいろためしましたがうまくいきませんのでどなたかアドバイスお願いいたします。


（出納帳のみ削除）
Private Sub 削除_Click()

MsgBox ("削除します。よろしいですか")

ActiveSheet.Unprotect
Selection.Range(Cells(1, 1), Cells(1, 8)).Delete Shift:=xlShiftUp（範囲指定）

Unload Me


End Sub

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2015/04/14 16:27

こんにちは。

>ActiveSheet.Unprotect
>Selection.Range(Cells(1, 1), Cells(1, 8)).Delete Shift:=xlShiftUp（範囲指定）

画像の「合計」の行の上がっていくことになると思います。空白行を作りたくない目的で、行のDeleteをしているのでしょうか？

私の作ったものと考え方がよく似ています。以下の行削除のマクロは、今から10年ぐらい前に作ったもので、未だ、現在まで使っています。ただ、削除する前に、その行をコピーして、バックアップシート・Worksheets("バックアップ")に削除した記録を取っています。一度も、その残骸にフィードバックしたことはありませんが。

同じ行に一致したものへの削除ですが、まず、削除する前に、配列での確保がよいのではないかと思います。そうしないと、出納帳で削除するのは、一番後になります。

※日付値の検索は、微妙な所があります。こちらは、Excel2010で作成しております。
以下の「 LookIn:=xlFormulas」の部分は、こちらでは成功していますが、他のバージョンでは分かりません。


'//昔から使っていたものなので、A65536が出てきています。
Sub TestMarco()
　Dim Rng As Range
　Dim Ar As Variant
　Dim sh As Worksheet
　Worksheets("出納帳").Unprotect
　Set Rng = ActiveCell.EntireRow.Range(Cells(1), Cells(8))
　Ar = Rng.Value
　If MsgBox(Rng.Cells(1).Value & vbCrLf & "を削除してよろしいですか？", 32 + vbOKCancel) = vbCancel Then Exit Sub
　Rng.Copy Worksheets("バックアップ").Range("A65536").End(xlUp).Offset(1)
　Rng.Delete Shift:=xlShiftUp
　For Each sh In Worksheets
　　If sh.Name <> "出納帳" And sh.Name <> "バックアップ" Then
　　　'もしかしたら、sh.Unprotect が必要かもしれません。
　　　Call FindAll(sh, Ar)
　　End If
　Next
End Sub

Sub FindAll(sh As Worksheet, baseArray As Variant)
　Dim srchVal As Variant
　Dim c As Range
　Dim i As Long
　Dim Arbuf As Variant
　srchVal = baseArray(1, 2) '日付値で探す
　With sh
　　Set c = sh.Cells.Find( _
　　What:=srchVal, _
　　LookIn:=xlFormulas, _
　　LookAt:=xlWhole, _
　　SearchOrder:=xlByColumns)
　　If c Is Nothing Then Exit Sub
　　Arbuf = c.EntireRow.Cells(1).Resize(, 8)
　　For i = 1 To UBound(baseArray, 2)
　　If Arbuf(1, i) <> baseArray(1, i) Then Exit For
　　Next i
　　If i > UBound(baseArray, 2) Then '完全一致
　　　c.EntireRow.Cells(1).Resize(1, 8).Delete Shift:=xlShiftUp
　　End If
　End With
　Set c = Nothing
End Sub
'///

この回答へのお礼

遅くなりました。参考にしながらなんとか完成しました。アドバイスありがとうございました。

お礼日時：2015/04/17 17:11