VBA 2表の差分抽出　1：2で出現するケースも差分として抽出したい

前提

「データ①」シート「データ②」シート「差分」シートがあり、
データ①にあってデータ②にないものを差分シートに書き出すプログラムがあるのですがもう一声カスタムしたいとおもっています

実現したいこと

データ①には「6/4　田中　ボールペン　400」というのが2つあります。データ②には一つしかない、でも以下のプログラムではデータ②に一行でもあれば差分として抽出しません。1：1で現れるケースは差分ではないけれどこの場合でいうと一行だけ「6/4　田中　ボールペン　400」を差分として抽出したいのです

補足

データ②も重複します。
データ①:データ②が、3:1 とか 4:1 になることもあります。
3:2などどちらも複数のケースもあります。
逆もしかりです。

3:1であれば2行抽出、 4:1 であれば3行抽出したいです。
3:2であれば３－２の１行抽出したいです。

実は製品の部品表の新旧リストを比較したいのですがリベットなどアセンブリの子部品として繰り返しでてくるものがいろいろありこのケースで増減あっても見えなくなってしまうため

員数ではなく行で出したいのは「削除すべきこの行が3行ありますよ」とか表現したいためです

エクセル2013です

該当のソースコード

Public Sub MainProc()
    Dim shtMain As Worksheet
    Dim motoName As String
    Dim sakiName As String
    Dim shtMoto As Worksheet
    Dim shtSaki As Worksheet
    Dim shtSabun As Worksheet
    Dim lastRowMoto As Long
    Dim lastRowSaki As Long
    Dim lastCol As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim blnSame As Boolean
    Dim blnExist As Boolean
    Dim nowRow As Long
    
    '①「メイン」シートを変数に格納する
    Set shtMain = ThisWorkbook.Sheets("メイン")
    
    '②比較元シート名を変数に格納する
    motoName = shtMain.Range("A2")
    
    '③比較先シート名を変数に格納する
    sakiName = shtMain.Range("B2")
    
    '④比較元シートを変数に格納する
    Set shtMoto = ThisWorkbook.Sheets(motoName)
            
    '⑤比較先シートを変数に格納する
    Set shtSaki = ThisWorkbook.Sheets(sakiName)
    
    '⑥差分シートを変数に格納する
    Set shtSabun = ThisWorkbook.Sheets("差分")
    
    '⑦比較元シートの最終行を取得する
    lastRowMoto = shtMoto.Cells(shtMoto.Rows.Count, 1).End(xlUp).Row
    
    '⑧比較元シートの最終列を取得する
    lastCol = shtMoto.Cells(1, shtMoto.Columns.Count).End(xlToLeft).Column
    
    '⑨比較先シートの最終行を取得する
    lastRowSaki = shtSaki.Cells(shtSaki.Rows.Count, 1).End(xlUp).Row
    
    '⑩差分シートをクリアする
    shtSabun.Cells.Clear
    
    '⑪比較元シートのヘッダー行を差分シートにコピーする
    shtMoto.Range(shtMoto.Cells(1, 1), shtMoto.Cells(1, lastCol)).Copy (shtSabun.Cells(1, 1))
    
    nowRow = 1
    
    '⑫比較元シートと比較先シートを比較し、差分行を差分シートにコピーする
    For i = 2 To lastRowMoto
    
        blnExist = False
    
        For j = 2 To lastRowSaki
        
            blnSame = True
            
            For k = 1 To lastCol
                If shtMoto.Cells(i, k) <> shtSaki.Cells(j, k) Then
                    blnSame = False
                    Exit For
                End If
            Next
            
            If blnSame = True Then
                blnExist = True
                Exit For
            End If
        Next
        
        If blnExist = False Then
            nowRow = nowRow + 1
            shtMoto.Range(shtMoto.Cells(i, 1), shtMoto.Cells(i, lastCol)).Copy (shtSabun.Cells(nowRow, 1))
        End If
    Next
    
    MsgBox "完了"
End Sub

考えたこと

If blnSame = True Then
が同じものがあった場合なにもしない…なのでのでここになにか条件を入れればいいような気がしているのですが見つかりません

もしくは別の発想でまったく別にプログラムをつくり同一のものを一行づつ削除し残ったものを抽出、という形でもいいのですがなにかいいアイデアOR方法ありますでしょうか…
ご教授願えましたら幸いです。

hatena19

2022/09/21 08:31 編集

確認ですが、データ①には重複する場合があるのは分かりましたが、データ②には重複はないということでいいですか。データ①:データ②が、3:1 とか 4:1 になることはありますか。あるなら、その場合は、差分はどうなりますか。3:1 でも1件建ての表示でいいですか。それとも、3-1の2件表示ですか。あと、エクセルのバージョンはなんでしょうか。

kumiko

2022/09/22 00:42 編集

データ②も重複します。データ①:データ②が、3:1 とか 4:1 になることもあります。逆もしかり。 3:1であれば2行抽出、 4:1 であれば3行抽出となります。実は製品の部品表の新旧を比較したいのですがリベットなどアセンブリの子部品として繰り返しでてくるものがいろいろあり増減が見えなくなってしまうのです…。員数ではなく行で出したいのは削除すべきこの行が3行あるよとか表現できるのでエクセル2013です

hatena19

2022/09/22 04:19

3:2の場合はどうなりますか？３-2の１行抽出でしょうか？

kumiko

2022/09/22 06:56

ご連絡ありがとうございます。そうなります。

行動規範の内容に同意します

回答2件

ベストアンサー

~~仕様があいまいな部分がありますが、とりあえず、下記で希望の結果になると思います。~~
質問が修正されて仕様が明確になったので、それにあわせてコードを修正しました。

vba
1Public Sub Sample()
2    Dim rngMoto As Range, rngSaki As Range
3    With ThisWorkbook.Sheets("メイン")
4        Set rngMoto = ThisWorkbook.Sheets(.Range("A2").Value).Cells(1).CurrentRegion
5        Set rngSaki = ThisWorkbook.Sheets(.Range("B2").Value).Cells(1).CurrentRegion
6    End With
7    
8    Dim shtSabun As Worksheet
9    Set shtSabun = ThisWorkbook.Sheets("差分")
10   
11    Dim dicSaki As Object
12    Set dicSaki = CreateObject("Scripting.Dictionary")
13   
14    Dim i As Long, key As String
15    For i = 2 To rngSaki.Rows.Count
16        key = Join(WorksheetFunction.Index(rngSaki.Rows(i).Value, 1, 0))
17        dicSaki(key) = dicSaki(key) + 1 'アイテムには件数を格納
18    Next
19    
20    shtSabun.Cells.Clear
21    rngSaki.Rows(1).Copy shtSabun.Cells(1, 1)
22    
23    Dim r As Long
24    r = 2
25    For i = 2 To rngMoto.Rows.Count
26        key = Join(WorksheetFunction.Index(rngMoto.Rows(i).Value, 1, 0))
27        If dicSaki.Exists(key) Then
28            dicSaki(key) = dicSaki(key) - 1 '一致したら件数を減らす
29            If dicSaki(key) = 0 Then dicSaki.Remove key '0件になったら削除する
30        Else
31            rngMoto.Rows(i).Copy shtSabun.Cells(r, 1)
32            r = r + 1
33        End If
34    Next
35End Sub

存在チェック(一致するものの検索)は、Dictionaryを使うのが高速というのが定番なので、それを使いました。

比較先のデータを連結して、Dictionaryにキーとして登録します。アイテムには件数を格納します。
比較元のデータを連結したものが、Dictionaryのキーに存在するかチェックして、存在しなければ、差分シートに出力。
存在した場合は、Dictionaryのアイテムの件数を減数して、0件になったら削除します。
これをループ処理すれば希望の結果になります。

投稿2022/09/21 11:30

編集2022/09/22 08:54

hatena19

総合スコア33757

kumiko

2022/09/22 01:38

申し訳ありません確認にお時間ください。

kumiko

2022/09/22 04:03

こちらのコメントと同内容ですが補足として追加修正いたしました。

hatena19

2022/09/22 08:55

質問修正後の仕様にあわせてコードを修正しました。確認ください。

kumiko

2022/09/27 01:28

ありがとうございます。質問に対する最良の回答をご提示くださったのだろうとおもいますが一見私にはハイレベルで( ;∀;) カスタムできるかという不安があったのですがなんとか使用したいフォーマットに合わせられました。確かに軽い！高速! 問題なく動作しました。ありがとうございます！

hatena19

2022/09/27 01:35

この回答の方法のポイントは連想配列(Dictionary)の使い方ですね。これを習得出来たら、今後、いろいろな場面で利用できると思いますので、ぜひ、頑張って理解してください。

kumiko

2022/09/27 02:01

解決とした後で申し訳ありませんが、もし可能であればご回答いただきたいのですが差分シートにヘッダー行をコピーするとき間に抜き出したい範囲、例えばA列からF列とするとC列やD列に空セルかあるとそこで止まってしまいますよね？ならば範囲指定してコピーとすると今度は下の検索がうまくいかなくなります。連想配列のキーがなにもないのかだめってことなのですかね… とりあえず間の空セルには先に「.」をいれて回避しているのですがほかにいい方法はありますでしょうか？

hatena19

2022/09/28 01:16 編集

ちょっと言葉だけでは状況が把握しづらいので、新規に質問をたてて、そちらで現状のシートの画像と、希望の結果の画像、現状のコードを提示して、どこがうまくいかないのか説明してください。

行動規範の内容に同意します

データ①の行が、データ②の行にマッチしたとき、以降そのデータ②の行を使用しないようにします。
最初にデータ②のE列にTRUEを設定しておき、
データ①の行が、データ②の行にマッチしたとき、その行をFALSEにします。
FALSEの行は、以降検索対象外とします。

VBA
1Public Sub MainProc()
2    Dim shtMain As Worksheet
3    Dim motoName As String
4    Dim sakiName As String
5    Dim shtMoto As Worksheet
6    Dim shtSaki As Worksheet
7    Dim shtSabun As Worksheet
8    Dim lastRowMoto As Long
9    Dim lastRowSaki As Long
10    Dim lastCol As Long
11    Dim i As Long
12    Dim j As Long
13    Dim k As Long
14    Dim blnSame As Boolean
15    Dim blnExist As Boolean
16    Dim nowRow As Long
17
18    '①「メイン」シートを変数に格納する
19    Set shtMain = ThisWorkbook.Sheets("メイン")
20
21    '②比較元シート名を変数に格納する
22    motoName = shtMain.Range("A2")
23
24    '③比較先シート名を変数に格納する
25    sakiName = shtMain.Range("B2")
26
27    '④比較元シートを変数に格納する
28    Set shtMoto = ThisWorkbook.Sheets(motoName)
29
30    '⑤比較先シートを変数に格納する
31    Set shtSaki = ThisWorkbook.Sheets(sakiName)
32
33    '⑥差分シートを変数に格納する
34    Set shtSabun = ThisWorkbook.Sheets("差分")
35
36    '⑦比較元シートの最終行を取得する
37    lastRowMoto = shtMoto.Cells(shtMoto.Rows.Count, 1).End(xlUp).Row
38
39    '⑧比較元シートの最終列を取得する
40    lastCol = shtMoto.Cells(1, shtMoto.Columns.Count).End(xlToLeft).Column
41
42    '⑨比較先シートの最終行を取得する
43    lastRowSaki = shtSaki.Cells(shtSaki.Rows.Count, 1).End(xlUp).Row
44
45    '⑨-1　比較先シートの作業列を作りフラグを立てる 追加
46    For i = 2 To lastRowSaki
47        shtSaki.Cells(i, lastCol + 1).Value = True  'True:未使用 False:使用済み
48    Next
49
50    '⑩差分シートをクリアする
51    shtSabun.Cells.Clear
52
53    '⑪比較元シートのヘッダー行を差分シートにコピーする
54    shtMoto.Range(shtMoto.Cells(1, 1), shtMoto.Cells(1, lastCol)).Copy (shtSabun.Cells(1, 1))
55
56    nowRow = 1
57
58    '⑫比較元シートと比較先シートを比較し、差分行を差分シートにコピーする
59    For i = 2 To lastRowMoto
60
61        blnExist = False
62
63        For j = 2 To lastRowSaki
64            '変更開始　未使用の列のみ処理する
65            If shtSaki.Cells(j, lastCol + 1).Value = True Then
66                blnSame = True
67
68                For k = 1 To lastCol
69                    If shtMoto.Cells(i, k) <> shtSaki.Cells(j, k) Then
70                        blnSame = False
71                        Exit For
72                    End If
73                Next
74
75                If blnSame = True Then
76                    blnExist = True
77                    shtSaki.Cells(j, lastCol + 1).Value = False    '追加　この列を使用済みにする
78                    Exit For
79                End If
80            End If
81            '変更終了
82        Next
83
84        If blnExist = False Then
85            nowRow = nowRow + 1
86            shtMoto.Range(shtMoto.Cells(i, 1), shtMoto.Cells(i, lastCol)).Copy (shtSabun.Cells(nowRow, 1))
87        End If
88    Next
89
90    MsgBox "完了"
91End Sub
92

投稿2022/09/21 10:52

tatsu99

総合スコア5458

tatsu99

2022/09/21 10:53

データ②のE列にTRUE/FALSEの残骸が残るのがいやなら、その行をクリアする処理を追加してください。

kumiko

2022/09/22 01:38

申し訳ありません確認にお時間ください。

kumiko

2022/09/22 07:43

ありがとうございます。質問のデータを変更し修正いただく形で大変ありがたいです。確認してみたところ現状このような結果になっておりますすみません、内容の確認はまだしっかりできておりませんが取り急ぎお伝えいたします。データ① 日付担当者商品名金額 2020/6/1 鈴木えんぴつ 250 2020/6/1 鈴木ボールペン 300 2020/6/1 佐藤えんぴつ 100 2020/6/2 鈴木ボールペン 600 2020/6/2 佐藤消しゴム 80 2020/6/2 田中えんぴつ 200 2020/6/3 佐藤消しゴム 240 2020/6/3 田中えんぴつ 250 2020/6/4 鈴木えんぴつ 150 2020/6/4 田中ボールペン 400 2020/6/4 田中ボールペン 400 2020/6/5 佐藤消しゴム 480 データ② 日付担当者商品名金額 2020/6/1 鈴木えんぴつ 250 FALSE 2020/6/1 鈴木ボールペン 400 TRUE 2020/6/1 佐藤えんぴつ 100 FALSE 2020/6/2 鈴木ボールペン 600 FALSE 2020/6/2 田中えんぴつ 200 TRUE 2020/6/3 佐藤消しゴム 240 TRUE 2020/6/3 田中えんぴつ 250 TRUE 2020/6/4 鈴木えんぴつ 150 TRUE 2020/6/4 田中ボールペン 400 TRUE 2020/6/5 鈴木えんぴつ 50 TRUE 2020/6/5 佐藤えんぴつ 150 TRUE 2020/6/5 佐藤消しゴム 480 FALSE 差分シート出力結果日付担当者商品名金額 2020/6/1 鈴木ボールペン 300 2020/6/2 佐藤消しゴム 80 2020/6/2 田中えんぴつ 200 2020/6/3 佐藤消しゴム 240 2020/6/3 田中えんぴつ 250 2020/6/4 鈴木えんぴつ 150 2020/6/4 田中ボールペン 400 2020/6/4 田中ボールペン 400

tatsu99

2022/09/22 08:21

提示されたデータ①、データ②をコピーしてこちらの環境で確認すると差分シートは以下のようになります。日付担当者商品名金額 2020/6/1 鈴木ボールペン 300 2020/6/2 佐藤消しゴム 80 2020/6/4 田中ボールペン 400 再度、確認していただけませんでしょうか。（こちらで提示したマクロで実行していない、データ①②が異なっている、等が考えられます）

tatsu99

2022/09/22 08:30

ちなみに、実際のデータ①、データ②は何行ほどありますか。かなりの件数があると処理時間がかかると思いますが、問題ないでしょうか。もし、遅いなら、この処理方法自体に問題があり、現状では、これ以上の改善は望めません。（画面表示の抑止などで多少は改善可能ですが・・・）その場合は、hatena19さんのマクロのほうが圧倒的に速くなりますので、そちらを採用してください。（但し、要件があいまいなままでのマクロだったので、現状では、あなたの要求する要件を満足できていません。いずれ、hatena19さんが修正版をアップしてくれるとは思いますが・・・）もし、大量のデータがあり、処理時間がかかりすぎるなら、その旨、返信してください。

kumiko

2022/09/22 13:44

申し訳ありません。再度確認の結果私のほうでも日付担当者商品名金額 2020/6/1 鈴木ボールペン 300 2020/6/2 佐藤消しゴム 80 2020/6/4 田中ボールペン 400 になりました。取り急ぎご連絡します。申し訳ありませんでした。実際のデータ行は基本50～100行程度で最大でも300くらいでしょうか…。横は50列くらいあります。処理に1分かからない程度であれば構いません。すでにいろいろカスタムしていたのでここに追加すればいいという方法でご提示くださったのはとてもありがたかったです。(私スキル低いので…) ただカスタム済の方に加えてみたらエラーになってしまったので…もう少しコード確認したいとおもいます。再度確認にお時間ください。

kumiko

2022/09/27 01:27

ありがとうございます！もう一声の一声をきけてすごいうれしかったし勉強になりました。問題なく動作しました。私の質問に対しての最良の回答で、ものすごくものすごくベストアンサーを迷ったのですがいかんせん実はやらなければならないカスタムがいろいろあって…(こちらの問題なのですが）処理が重たくなってしまうため今回はhatena19さんのプログラムを採用させていただきます。私目線に寄り添っていただいた回答まことに感謝いたします。

行動規範の内容に同意します

あなたの回答