【再】エクセル2013 マクロをご教示ください

質問

Sheet1で選択しているセルの行をSheet2に転写したいです。

Sheet1とSheet2の4行目に見出し。
Shet1にはA～U列までデータがあります。(途中空白セルの場合もあり)
Sheet1の5行目以降の、あるセルを選択してマクロを実行すると
Sheet1のC～S列までをSheet2のA～Q列へコピペしたいです。

Sheet1は　H列に必ずデータがあるので
それらを最終行の判断基準とします。

Sheet1での選択セルは複数の場合もあります。
ただし、同じ行のセルを複数選択しても
Sheet2への貼り付けは1行とします。

マクロを実行する度に、Sheet1での選択セルの該当行が
Sheet2へ追加されるようにしたいです。
(Sheet2へコピペされたデータは残します)

また、Sheet2への貼り付け内容が同じだった場合は
注意喚起のため　メッセージで　「重複データが存在します」を表示したいです。
重複の判断基準はSheet2の　B、D、F列とします。

宜しくお願い致します。

回答No.2

keithin · ベストアンサー

「重複あり」の警告を出した後どうしたいのかが詰まってませんね。
またご相談の書き振りから、今回は自動起動マクロじゃなく、イチイチ手で起動するマクロにします。

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

お礼

動作確認しました。
完璧です。
ありがとうございました。

回答No.1

soixante

求めている形かはわかりませんが・・・

・シート1の５行目から最終行まで　Do Loop で回しています。
・intersect を用いて、その行に選択セルがあるかどうかで if 分岐しています。
・セルが選択されている行の場合、シート２に重複データがあるかを、if 分岐しています。（入れ子）
・重複データがあったとき続けるかどうかをMsgbox で表示し、その返答をResで受け、Resによって対応を変えています。（さらに内側のifの入れ子）
・ResがＮｏ（＝継続しない）の場合、Exit Sub で途中で終えています。
・重複の判定はシート２のＢ列だけでやってしまったので、適宜変更してください。

※試行時には必ず元データのバックアップを取ったうえでお願いします。

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

どうでしょうか。試行時には必ずバックアップを取ったうえでお願いします。

お礼

説明文も付けて頂きとても理解しやすかったです。
冒頭で仰っていますが、少し求めているものと違いました。
今後の参考にさせて頂きます。
ありがとうございました。