プロが教えるわが家の防犯対策術!

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

□sheet1
123@gmail.com
1234@gmail.com
12345@gmail.com
123456@gmail.com
.....何行あるかは未定

□sheet2
123@gmail.com
123@yahoo.co.jp
12345@yahoo.co.jp
1234567@gmail.com
.....何行あるかは未定

□sheet3
123@yahoo.co.jp
12345@yahoo.co.jp
1234567@gmail.com

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

VBAお助け願います

A 回答 (17件中1~10件)

#6です。


VBAでなければならないのですか。関数ではだめですかね。
#6で UNIQUE は使えると思うという回答があったので。
sheet1の続きに、sheet2をコピーして、(A列にデータがあるとして)
sheet3に 
=UNIQUE(sheet1!A:A)
でいけると思いますがいかがですか。
    • good
    • 0

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
    • good
    • 0

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
    • good
    • 1

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


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

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
    • good
    • 0

#12です。


間違いがありましたので訂正いたします。
検証せずに投稿してしまい申し訳ありません。
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)
    • good
    • 0
この回答へのお礼

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

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

こんにちは、


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

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

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

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

こんにちは!



一例です。
尚、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
    • good
    • 0
この回答へのお礼

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

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

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


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

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

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

正常に動作する条件です



1.シート1と2の データの開始と終了の行が同じであること
2.シート1と2のデータの列が同じであること

この条件が合致しないと正しく動作しません
もし シート1,2でそれらが違うなら
下駄をはかせて合わせてください
    • good
    • 0
この回答へのお礼

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

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

これではどうですか?



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
    • good
    • 0
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング