ＶＢＡ重複チェック

ＶＢＡお助け願います
①sheet1：元データ
②sheet2：追加分データ
③sheet3：ＶＢＡ実行結果を貼り付けるシート
※リストはアドレスになります

□sheet1
[e-mail]
[e-mail]
[e-mail]
[e-mail]
.....何行あるかは未定

□sheet2
[e-mail]
[e-mail]
[e-mail]
[e-mail]
.....何行あるかは未定

□sheet3
[e-mail]
[e-mail]
[e-mail]

sheet2に貼り付けられたデータ（何個あるかは未定）をsheet1のデータの中から
重複チェックを行い、重複しないデータをsheet3に貼り付ける
※実行する前の段階でsheet3は何も記入されていないsheetとします
※1回実行させた分に関し重複しないデータはsheet1に追加していくので
sheet1は常に増えていきます

ＶＢＡお助け願います

No.17 回答者： banzaiA 回答日時： 2020/09/08 22:26

#6です。

VBAでなければならないのですか。関数ではだめですかね。
＃６で　UNIQUE　は使えると思うという回答があったので。
sheet1の続きに、sheet２をコピーして、(A列にデータがあるとして）
sheet３に　
＝UNIQUE（sheet1!A:A)
でいけると思いますがいかがですか。

No.16 回答者： shut0325 回答日時： 2020/09/08 17:27

shut0325です。

他の方がすでに回答されているようですが、私の回答で書いていたものをベタにコードにしたものです。
ごく基礎的な処理（for文とIf文）でやっていますので、ご自身でVBAを学ばれる際の参考になればと思います。


Sheet1に追加するタイプの物で、各シートのA列1行目からリストが書かれている想定です。



Sub リスト追加()

Set WS1 = Worksheets("sheet1")
Set WS2 = Worksheets("sheet2")

S1RowEnd = WS1.Cells(Rows.Count, 1).End(xlUp).Row
S2RowEnd = WS2.Cells(Rows.Count, 1).End(xlUp).Row

S1WP = S1RowEnd + 1

For i = 1 To S2RowEnd

For j = 1 To S1RowEnd

If WS2.Cells(i, 1).Value = WS1.Cells(j, 1).Value Then

Exit For

End If

Next j

If j = S1RowEnd + 1 Then

WS1.Cells(S1WP, 1).Value = WS2.Cells(i, 1).Value
S1WP = S1WP + 1

End If

Next i

MsgBox ("処理が完了しました")

End Sub

No.15 回答者： fujillin 回答日時： 2020/09/08 16:47

No2です

Sheet2の非重複データを、直接Sheet1に追加するごく簡単なサンプルです。

No2で回答した方法で処理していますので、Sheet2のB列を作業列として利用しています。
（B列をすでに使っている場合は、別の列にすれば良いです）
Sheet3が必要な場合は、先にSheet1をSheet3にコピペしてからSheet3に対して実行するようにすればよいでしょう。

Sub Sample()
Dim r, d
Set d = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1)

With Worksheets("Sheet2")
　Set r = .Cells(1, 2).Resize(.UsedRange.Rows.Count)
　r.FormulaLocal = "=if(COUNTIF(Sheet1!A:A,A1)=0,1,"""")"
　r.Value = r.Value
　If Application.Sum(r) > 0 Then
　　r.SpecialCells(xlTextValues).Offset(, -1).Copy Destination:=d
　End If
　r.ClearContents
End With
End Sub

No.14 回答者： naktak 回答日時： 2020/09/08 16:46

動くコードがほしいと言われたので作りました。

ざっくりなので、自分で理解して、自分のものとして落とし込んでください。

Public Sub Test()
' 値の走査を行うSheet2の開始行
Const FirstRowIndex As Long = 1

' 値の出力を行うSheet3の開始行
Const OutputFirstRowIndex As Long = 1

Dim compareWs As Worksheet
Dim targetWs As Worksheet
Dim destWs As Worksheet

Set compareWs = Worksheets("Sheet1")
Set targetWs = Worksheets("Sheet2")
Set destWs = Worksheets("Sheet3")

' Sheet2の最終行を取得
Dim lastRowIndex As Long
lastRowIndex = targetWs.Range("A1").SpecialCells(xlCellTypeLastCell).Row

Dim i As Long
Dim j As Long
j = OutputFirstRowIndex
For i = FirstRowIndex To lastRowIndex
Dim targetValue As String
targetValue = targetWs.Cells(i, 1).Value

' Sheet1のA列に対してCOUNTIFを実施し、見つからないものをSheet3に出力
Dim containsCount As Long
containsCount = Application.WorksheetFunction.CountIf(compareWs.Range("A:A"), targetValue)
If containsCount < 1 Then
destWs.Cells(j, 1).Value = targetValue
j = j + 1
End If
Next
End Sub

No.13 回答者： Qchan1962 回答日時： 2020/09/08 16:43

＃１２です。

間違いがありましたので訂正いたします。
検証せずに投稿してしまい申し訳ありません。
Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Resize(UBound(Ary)) = Application.Transpose(Ary)
最終行にダブって入力されるので間違い。
下記で新規行に追加されます。
Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(Ary)) = Application.Transpose(Ary)

この回答へのお礼

お手間とらせてしまい申し訳ございません

お礼日時：2020/09/08 16:48

No.12 回答者： Qchan1962 回答日時： 2020/09/08 16:30

こんにちは、

VBAがご希望と言う事で取敢えずデータ加工が出来れば良いのかと
よくある私的アドバイスは割愛します。
Sheet1の最終行に追加されます。

Sub sple()
Dim Ary, Rng, n As Long
ReDim Ary(Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row)
For Each Rng In Sheets("sheet2").Range("A1", Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp))
If Application.CountIf(Sheets("sheet1").Range("A:A"), Rng.Value) = 0 Then
Ary(n) = Rng.Value
n = n + 1
End If
Next
Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Resize(UBound(Ary)) = Application.Transpose(Ary)
End Sub

内容は、＃１さんのアドバイスと同じようなものです。
苦言を呈すなら、
＃１＃２さんのアドバイスで自身で作成する事に挑戦するべきかと思います。
この時点で作成したものを補足で足すとか、、、まぁ
作ってくれる私みたいな無責任な者がいるので必要ないかもしれませんが、
直す時は苦労すると思いますので、、、

この回答へのお礼

お手間とらせてしまい申し訳ございません

お礼日時：2020/09/08 16:47

No.11 回答者： tom04 回答日時： 2020/09/08 16:29

こんにちは！

一例です。
尚、Sheet1・Sheet2とも1行目からデータはあるとします。

標準モジュールにしてください。

Sub Sample1()
　Dim i As Long
　Dim c As Range
　Dim cnt As Long
　Dim wS1 As Worksheet, wS2 As Worksheet

　　Set wS1 = Worksheets("Sheet1")
　　Set wS2 = Worksheets("Sheet2")
　　　With Worksheets("Sheet3")
　　　　.Range("A:A").ClearContents '//←Sheet3、A列データを一旦消去//
　　　　　For i = 1 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　Set c = wS1.Range("A:A").Find(what:=wS2.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　　If c Is Nothing Then
　　　　　　　　cnt = cnt + 1
　　　　　　　　　.Cells(cnt, "A") = wS2.Cells(i, "A")
　　　　　　　End If
　　　　　Next i
　　　　.Activate
　　　End With
　　　　MsgBox "完了"
End Sub

※　他の方のお礼欄にSheet1に追加云々とありますが、
とりあえず、Sheet1のA列にないSheet2A列のデータをSheet3のA列に表示するようにしています。m(_ _)m

この回答へのお礼

ありがとうございます！！
やりたいことが一発でできました！！
感動しました。

お礼日時：2020/09/08 16:46

No.10 回答者： ppp2122 回答日時： 2020/09/08 16:23

そうなると　ループをネストしてすべてのデータ行を

確認しないといけませんね
そうであるならそう書かないと　正しい回答は得られません
また、　後だしじゃんけんのような感じになると
回答者は萎えてしまい　もうやーめた　となります

この回答へのお礼

説明不足で申し訳ありません。

お礼日時：2020/09/08 16:25

No.9 回答者： ppp2122 回答日時： 2020/09/08 16:14

正常に動作する条件です

１．シート１と２の　データの開始と終了の行が同じであること
２．シート１と２のデータの列が同じであること

この条件が合致しないと正しく動作しません
もし　シート１，２でそれらが違うなら
下駄をはかせて合わせてください

この回答へのお礼

なるほど。かしこまりました。
ただsheet1にはsheet2と重複しないもののみ追加していくので
sheet1の行＝sheet2の行は必ずしも成立しません

お礼日時：2020/09/08 16:17

No.8 回答者： ppp2122 回答日時： 2020/09/08 16:08

これではどうですか？

sub 不一致チェック再()

Dim Sh1 As Worksheet, Sh2 As Worksheet, sh3 As Worksheet
Dim i As Long
Dim Startrow As Long
Dim Lastrow1 As Long
Dim Lastrow2 As Long
Set Sh1 = Worksheets("sheet1")
Set Sh2 = Worksheets("sheet2")
Set sh3 = Worksheets("sheet3")

Startrow = 1
Lastrow1 = Sh1.Cells(1048576, 1).End(xlUp).Row
Lastrow2 = Lastrow1 + 1
For i = Startrow To Lastrow1
If Sh1.Cells(i, 1).Value <> Sh2.Cells(i, 1).Value Then
Sh1.Cells(Lastrow2, 1).Value = Sh2.Cells(i, 1).Value
Lastrow2 = Lastrow2 + 1
End If

Next i

End Sub

この回答へのお礼

何度もお手間とらせてしまい申し訳ありません。
上記で実行させたところ、sheet1の最後尾に貼り付けるように組んでいただいたかと思いますが
不一致条件を読んでおらず、同じものがあるのに最後尾に張り付くようになってしまっております。

お礼日時：2020/09/08 16:14