「重複あり」の警告を出した後どうしたいのかが詰まってませんね。
またご相談の書き振りから、今回は自動起動マクロじゃなく、イチイチ手で起動するマクロにします。
sub macro1()
dim h as range
dim Target as range
dim w2 as worksheet
dim buf as range
set w2 = worksheets("Sheet2")
set buf = selection
set target = application.intersect(selection.entirerow, range("A5:A" & rows.count))
if target is nothing then exit sub
for each h in target
if cells(h.row, "H") <>"" then
if application.countifs(w2.range("B:B"), cells(h.row, "D"), w2.range("D:D"), cells(h.row, "F"), w2.range("F:F"), cells(h.row, "H")) > 0 then
h.entirerow.select
msgbox "重複あり"
buf.select
exit sub
else
range(cells(h.row, "C"), cells(h.row, "S")).copy _
destination:=w2.cells(w2.range("F65536").end(xlup).offset(1).row, "A")
end if
end if
next
end sub
求めている形かはわかりませんが・・・
・シート1の5行目から最終行まで Do Loop で回しています。
・intersect を用いて、その行に選択セルがあるかどうかで if 分岐しています。
・セルが選択されている行の場合、シート2に重複データがあるかを、if 分岐しています。(入れ子)
・重複データがあったとき続けるかどうかをMsgbox で表示し、その返答をResで受け、Resによって対応を変えています。(さらに内側のifの入れ子)
・ResがNo(=継続しない)の場合、Exit Sub で途中で終えています。
・重複の判定はシート2のB列だけでやってしまったので、適宜変更してください。
※試行時には必ず元データのバックアップを取ったうえでお願いします。
-----------------------------------------------------------------------
Sub aaa()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim r As Long, c As Integer, Lstrow As Long
Dim Wsf As Object, Res As Integer
Set Ws1 = Worksheets("sheet1")
Set Ws2 = Worksheets("sheet2")
Set Wsf = Application.WorksheetFunction
Ws1.Select
r = 5
Do While Ws1.Cells(r, 8).Value <> ""
If Not Intersect(Selection, Rows(r)) Is Nothing Then 'セルが選択されている行の場合
If Wsf.CountIf(Ws2.Columns(2), Ws1.Cells(r, 4).Value) > 0 Then '重複データがある場合
Res = MsgBox(r & "行目は重複データ。続けますか?", vbYesNo)
If Res = vbNo Then 'いいえ
MsgBox "終了します"
Application.CutCopyMode = False
Exit Sub
ElseIf Res = vbYes Then 'はい
With Ws1
.Range(.Cells(r, 3), .Cells(r, 19)).Copy
End With
Lstrow = Ws2.Cells(Rows.Count, 8).End(xlUp).Row + 1
Ws2.Cells(Lstrow, 1).PasteSpecial Paste:=xlPasteAll
End If
Else '重複データでない場合
With Ws1
.Range(.Cells(r, 3), .Cells(r, 19)).Copy
End With
Lstrow = Ws2.Cells(Rows.Count, 8).End(xlUp).Row + 1
Ws2.Cells(Lstrow, 1).PasteSpecial Paste:=xlPasteAll
End If
Else 'セルが選択されていない場合
End If
r = r + 1
Loop
Application.CutCopyMode = False
MsgBox "完了"
Set Ws1 = Nothing
Set Ws2 = Nothing
Set Wsf = Nothing
End Sub
---------------------------------------------------------------
どうでしょうか。試行時には必ずバックアップを取ったうえでお願いします。
お礼
動作確認しました。 完璧です。 ありがとうございました。