• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:【再】エクセル2013 マクロをご教示ください)

【再】エクセル2013 マクロの実行方法とデータの転写手順を教えてください

このQ&Aのポイント
  • エクセル2013でマクロを実行してデータを転写する手順を教えてください。
  • 選択したセルの行をSheet 2に転写する方法を教えてください。また、重複データが存在する場合は注意喚起を表示する方法も知りたいです。
  • マクロの実行時にSheet 1で選択したセルの行をSheet 2にコピーする方法を教えてください。また、重複データの判定基準はSheet 2の特定の列とします。

質問者が選んだベストアンサー

  • ベストアンサー
  • keithin
  • ベストアンサー率66% (5278/7941)
回答No.2

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

maron1010
質問者

お礼

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

その他の回答 (1)

  • soixante
  • ベストアンサー率32% (401/1245)
回答No.1

求めている形かはわかりませんが・・・ ・シート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 --------------------------------------------------------------- どうでしょうか。試行時には必ずバックアップを取ったうえでお願いします。

maron1010
質問者

お礼

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

関連するQ&A

専門家に質問してみよう