[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『表を比較して差分をチェックして表示』（コッペ）
以下の仕様にそったVBAを作成したいと思います。
参考になるweb記事等有りましたら紹介ください。
まだコードは、まだ手つかずな状態なので
以下の仕様ではなくこうした方が良いと言うアドバイスもあれば紹介下さい。
「やりたい事」
両者に存在する場合は、「○」を無い項目には「X」を表記したい。
「具体例の簡単なサンプル」
例えば、Sheet１のB列とSheet2のB列の「品名」を比較して
Sheet3に両者にある場合は、「○」、Sheet２に合ってSheet1には無い場合は「X」を記入
Sheet1
|[A] |[B] |[C]
[1]|Check|品名 |単価
[2]| |いちご| 250
[3]| |なし | 85
[4]| |りんご| 60
[5]| |みかん| 40
[6]| |メロン| 120
Sheet2
|[B]
[1]|品名
[2]|なし
[3]|みかん
[4]|もも
Sheet3
|[A] |[B] |[C] |[D]|[E] |[F]
[1]|Check|品名 |単価| |Check|品名
[2]| |いちご| 250| |X |もも
[3]|○ |なし | 85| | |
[4]| |りんご| 60| | |
[5]|○ |みかん| 40| | |
[6]| |メロン| 120| | |
[7]| | | | |
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
１）Sheet1にあって、Sheet2に無い場合はどうするんですか？ ２）Sheet1またはSheet2に重複がある場合はどうしますか？ （稲葉） 2023/03/10(金) 11:21:58
仕様について(アドバイスという訳ではないのですが)個人的には↓こんなイメージを持ってます。
Sheet1 Sheet2 _|___A____|___B____| _|___A____| 1|品名 |単価 | 1|品名 | 2|いちご | 250| 2|なし | 3|なし | 85| 3|みかん | 4|りんご | 60| 4|もも | 5|みかん | 40| 6|メロン | 120|
Sheet3(照合結果)
_|___A____|___B____|___C____|___D____|
1| |Sheet1 |Sheet1 |Sheet2 |←照合後の業務を考慮すると
2|chk |品名 |単価 |品名 | 両方のシートの全カラムを出力しておいた方がいい気がする
3| 1|いちご | 250| |
4| 3|なし | 85|なし |
5| 1|りんご | 60| |
6| 3|みかん | 40|みかん |
7| 1|メロン | 120| |
8| 2| | |もも |
↑
1:Sheet1にだけ存在
2:Sheet2にだけ存在
3:両方に存在
またn対n照合が必要な場合はもう1列用意して、そこで照合番号を管理するとか。
（白茶） 2023/03/10(金) 11:43:12
＞Sheet1にあって、Sheet2に無い場合はどうするんですか？
その場合は、無視して下さい。
なのでSheet３のCheckには、「○」も「X」も記入されません。
＞Sheet1またはSheet2に重複がある場合はどうしますか？
重複は無い前提です。
表はそれぞれソートして同名が無いことを確認しています
（コッペ） 2023/03/10(金) 11:56:17
確かに提唱された形式の表形式の方が見やすいですね。
但し、後出し条件で気が重いのですが項目が、品名、単価の他に後３個ほどあるので
提唱された形式では少し横長の形式になりますが
列を一部非表示にすれば違いは見えやすくなるので対処できそうです。
（コッペ） 2023/03/10(金) 11:56:43
両方に存在する場合は、以下で「３」が記入されますが
片方だけに存在する場合の「１」、「２」のVBAで思考停止しています。
アドバイスお願いします。
Sub test()
Dim L As Long
Dim R As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Set ws3 = Worksheets("sheet3")
ws1.UsedRange.Copy Destination:=ws3.Range("B1")
ws2.UsedRange.Copy Destination:=ws3.Range("D1")
For R = 2 To ws3.Cells(Rows.Count, "D").End(xlUp).Row
For L = 2 To ws3.Cells(Rows.Count, "B").End(xlUp).Row
If ws3.Cells(R, "D").Value = ws3.Cells(L, "B").Value Then
ws3.Cells(L, "A").Value = 3
Exit For
End If
Next
Next
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
End Sub
（コッペ） 2023/03/10(金) 13:37:39
Sub test()
Dim L As Long
Dim R As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Set ws3 = Worksheets("sheet3")
'オートフィルター解除(初期化)
ws3.Range("A1").AutoFilter
'書き出しシート全体をクリアする
ws3.Cells.Clear
'書き出しシートへ元DATAコピペ
ws1.UsedRange.Copy Destination:=ws3.Range("B1")
'表を比較 （同一ならA列に「1」を書き込み）
For R = 2 To ws2.Cells(Rows.Count, "B").End(xlUp).Row
For L = 2 To ws1.Cells(Rows.Count, "B").End(xlUp).Row
If ws2.Cells(R, "B").Value = ws1.Cells(L, "B").Value Then
ws3.Cells(L, "A").Value = 1
Exit For
End If
Next
Next
'オートフィルターで同一の項目のみ表示
ws3.Range("A1").AutoFilter , field:=1, Criteria1:="1"
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
End Sub
（コッペ） 2023/03/10(金) 16:30:57
>両方に存在する品名のみ書き出すようにしました
では、その後
Sheet2に残ったものを下に追加する
...って段階的にやった方らいいと思います。
(↓はDictionaryを使う例として...)
Dim r As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Set ws3 = Worksheets("sheet3")
Dim Dic2 As Object, Key As String
Dim vR1 As Range, vR2 As Range, vW1(), vW2(), vW3(), vW4()
Set Dic2 = CreateObject("Scripting.Dictionary")
Set vR1 = ws1.UsedRange
Set vR2 = ws2.UsedRange
ReDim vW1(1 To vR1.Rows.Count, 1 To 1)
vW3 = vW1
ReDim vW2(1 To vR2.Rows.Count, 1 To 1)
For r = 2 To vR2.Rows.Count
Dic2(vR2.Cells(r, 1).Value) = r
Next
For r = 2 To vR1.Rows.Count
vW1(r, 1) = 1
Key = vR1.Cells(r, 1).Value
If Dic2.Exists(Key) Then
vW1(r, 1) = 3
vW3(r, 1) = Key
vW2(Dic2(Key), 1) = 3
End If
Next
vW1(1, 1) = "Check"
vW3(1, 1) = "品名(" & ws2.Name & ")"
ws3.Cells.Clear
ws1.UsedRange.Copy Destination:=ws3.Range("B1")
ws3.Range("A1").Resize(vR1.Rows.Count) = vW1
ws3.Range("D1").Resize(vR1.Rows.Count) = vW3
Dim i As Long
ReDim vW4(1 To vR2.Rows.Count - 1, 1 To 4)
For r = 2 To vR2.Rows.Count
If vW2(r, 1) = Empty Then
i = i + 1
vW4(i, 1) = 2
vW4(i, 4) = vR2.Cells(r, 1).Value
End If
Next
If i > 0 Then ws3.Range("A1").Offset(vR1.Rows.Count).Resize(i, 4).Value = vW4
（白茶） 2023/03/10(金) 16:59:22
衝突したけど、最初に提示いただいたデータ通りに仕上げました・・・
Sub test2()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Set ws3 = Worksheets("sheet3")
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim tbl As Variant, buf As String
Dim r As Range, i As Long
'Sheet2の一覧表をDicに取込
For Each r In ws2.Range("B2", ws2.Cells(Rows.Count, "B").End(xlUp))
dic(r.Value) = 0
Next r
'Sheet1のデータを配列に取込
tbl = ws1.[A1:C1].Resize(ws1.Cells(Rows.Count, "B").End(xlUp).Row).Value
'Sheet1のB列を2行目からループしてありなしを判定
For i = 2 To UBound(tbl, 1)
buf = tbl(i, 2)
If dic.exists(buf) Then
tbl(i, 1) = "○"
dic.Remove buf
End If
If dic.Count = 0 Then Exit For
Next i
'結果の出力
With ws3
.Cells.Clear
.Range("B1").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
'Sheet1になかったものを出力
If dic.Count > 0 Then
.[E1:F1].Value = [{"Check","品名"}]
.[E2].Resize(dic.Count).Value = "X"
.[F2].Resize(dic.Count).Value = Application.Transpose(dic.keys)
End If
End With
MsgBox "出力しました"
End Sub
（稲葉） 2023/03/10(金) 17:24:15
ステップアップ実行やローカルウインドウ等を利用してコードを追いかけましたが
Dictionaryや配列を利用した方法は、現在の私の立ち位置では難しく感じます。
ただ結果だけを求めるのあればいただいたコードをそのまま利用すれば良いのですが
それではスキルアップになりません。
（現在スキル不足で3/10 16:30で上げたコード程度しか書くことができません。）
すみませんが、形式は一番最初の質問でのSheet3のような形式で
私にも理解できそうな他の方法で回答をいただけると理解が進むのですがお願いできないでしょうか？
区分は、Sheet2にだけ存在は「X」、両方に存在する場合は、「○」でSheet1にだけ存在する場合は「」（未チェック）
でお願いします。
（コッペ） 2023/03/11(土) 08:08:58
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rng1 As Range, rng2 As Range, rng3 As Range, i As Long
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
Set rng1 = ws1.Range("B2").Resize(ws1.Cells(Rows.Count, 2).End(xlUp).Row - 1)
Set rng2 = ws2.Range("B2").Resize(ws2.Cells(Rows.Count, 2).End(xlUp).Row - 1)
For Each rng3 In ws3.Range("B2").Resize(ws3.Cells(Rows.Count, 2).End(xlUp).Row - 1)
With WorksheetFunction
If .CountIf(rng1, rng3) > 0 And .CountIf(rng2, rng3) > 0 Then rng3.Offset(0, -1) = "○"
End With
Next
For i = 1 To rng2.Count
With ws3.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
If WorksheetFunction.CountIf(rng1, rng2(i)) = 0 Then
ws3.Cells(.Row, "E") = "X"
ws3.Cells(.Row, "F") = rng2(i)
End If
End With
Next
End Sub
（フォーキー） 2023/03/11(土) 08:44:26
大前提として、配列やDictionaryを学ぶことこそが、スキルアップにつながると思っています。 それを踏まえて「私にも理解できそうな他の方法」となると、 For〜Next をSheet2側からも行う感じになるのでは。 出来るだけ元のコードを維持しています。
Sub test()
Dim L As Long
Dim R As Long
Dim rw As Long
Dim flg As Boolean
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
'オートフィルター解除(初期化)
' ws3.Range("A1").AutoFilter
'書き出しシート全体をクリアする
ws3.Cells.Clear
'書き出しシートへ元DATAコピペ
ws1.UsedRange.Copy Destination:=ws3.Range("A1")
'Sheet1の表を上から順にSheet2の表と比較（同一ならSheet3のA列に「○」を書き込み）
For R = 2 To ws1.Cells(Rows.Count, "B").End(xlUp).Row
For L = 2 To ws2.Cells(Rows.Count, "B").End(xlUp).Row
If ws1.Cells(R, "B").Value = ws2.Cells(L, "B").Value Then
ws3.Cells(R, "A").Value = "○"
Exit For
End If
Next
Next
'Sheet2の表を上から順にSheet1の表と比較
rw = 2
ws3.Range("E1").Resize(, 2) = Array("Check", "品名") '見出し書込み
For R = 2 To ws2.Cells(Rows.Count, "B").End(xlUp).Row
flg = False
For L = 2 To ws1.Cells(Rows.Count, "B").End(xlUp).Row
If ws2.Cells(R, "B").Value = ws1.Cells(L, "B").Value Then
flg = True 'Sheet1に有ったのでフラグを立てる
Exit For
End If
Next
If flg = False Then
'フラグが立ってない＝Sheet2にしか存在しない
ws3.Cells(rw, "E").Value = "X"
ws3.Cells(rw, "F").Value = ws2.Cells(R, "B").Value
rw = rw + 1
End If
Next
'オートフィルターで同一の項目のみ表示
' ws3.Range("A1").AutoFilter , field:=1, Criteria1:="○"
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
End Sub
（ポリタンク） 2023/03/11(土) 09:51:43
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rng1 As Range, rng2 As Range, rng3 As Range, i As Long
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
ws1.Range("A1").CurrentRegion.Copy ws3.Range("A1")
ws3.Range("A1:B1").Copy ws3.Range("E1")
Set rng1 = ws1.Range("B2").Resize(ws1.Cells(Rows.Count, 2).End(xlUp).Row - 1)
Set rng2 = ws2.Range("B2").Resize(ws2.Cells(Rows.Count, 2).End(xlUp).Row - 1)
Set rng3 = ws3.Range("A2").Resize(ws3.Cells(Rows.Count, 2).End(xlUp).Row - 1)
rng3.Formula = "=IF(COUNTIF(" & ws2.Name & "!" & rng2.Address & ",B2)>0,""○"","""")"
rng3.Value = rng3.Value
For i = 1 To rng2.Count
With ws3.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
If WorksheetFunction.CountIf(rng1, rng2(i)) = 0 Then
ws3.Cells(.Row, "E") = "X"
ws3.Cells(.Row, "F") = rng2(i)
End If
End With
Next
End Sub
※10:36数式修正 （フォーキー） 2023/03/11(土) 10:23:56
質問内容とは違いますが、数式案です。 ※セル範囲を多めにとれば、変数不要でもっとスマートになるかも。
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim adr1 As String, adr2 As String, adr3 As String, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
Set rng = ws3.Range("A2").Resize(ws1.Cells(Rows.Count, 2).End(xlUp).Row - 1)
ws1.Range("A1").CurrentRegion.Copy ws3.Range("A1")
ws3.Range("A1:B1").Copy ws3.Range("E1")
adr1 = ws1.Name & "!" & ws1.Range("B2").Resize(ws1.Cells(Rows.Count, 2).End(xlUp).Row - 1).Address(0, 0)
adr2 = ws2.Name & "!" & ws2.Range("B2").Resize(ws2.Cells(Rows.Count, 2).End(xlUp).Row - 1).Address(0, 0)
adr3 = ws2.Name & "!" & ws2.Range("B2").Resize(ws2.Cells(Rows.Count, 2).End(xlUp).Row - 1).Address
rng.Formula = "=IF(COUNTIF(" & adr3 & ",B2)>0,""○"","""")"
ws3.Range("F2").Formula2 = "=FILTER(" & adr2 & ",COUNTIF(" & adr1 & "," & adr2 & ")=0)"
ws3.Range("A1").Resize(rng.Rows.Count, 6).Value = ws3.Range("A1").Resize(rng.Rows.Count, 6).Value
End Sub
（フォーキー） 2023/03/11(土) 11:03:50
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
Set rng = ws3.Range("A2").Resize(ws1.Cells(Rows.Count, 2).End(xlUp).Row - 1)
ws1.Range("A1").CurrentRegion.Copy ws3.Range("A1")
ws3.Range("A1:B1").Copy ws3.Range("E1")
ws3.Range("A2").Resize(ws1.Cells(Rows.Count, 2).End(xlUp).Row - 1).Formula = "=IF(COUNTIF(" & ws2.Name & "!$B$2:$B$10,B2)>0,""○"","""")"
ws3.Range("F2").Formula2 = "=FILTER(IF(" & ws2.Name & "!B2:B10="""",""""," & ws2.Name & "!B2:B10),COUNTIF(" & ws1.Name & "!B2:B10," & ws2.Name & "!B2:B10)=0)"
ws3.Range("$E$2:$E$10").Formula = "=IF(F2<>"""",""X"","""")"
ws3.Range("A1").Resize(rng.Rows.Count, 6).Value = ws3.Range("A1").Resize(rng.Rows.Count, 6).Value
End Sub
（フォーキー） 2023/03/11(土) 11:25:38
If ws2.Cells(R, "B").Value = ws1.Cells(L, "B").Value Then で
「○」を処理して
else で
「ｘ」を処理しようとしてうまく行かずにいましたが
おかげさまでflagを利用する方法で処理できました。
フォーキーさん、何度もコードを書き換えていただき感謝します。
一応自前のコードが解決したのでじっくり見させて頂きます。
（コッペ） 2023/03/11(土) 12:59:39
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.