データ比較してＶＢＡ

Question

いつもお世話になっております。
下記のコードは
'A列にありB列にないデータを作成
'B列にありA列にないデータを作成
をつくるコードです。ググって見つけました。

ここで'A列とB列どちらにもあるデータを作成
するにはどうしたらよいのかおしえてくれませんでしょうか


Public Sub データ比較()
Dim row As Long
Dim row2 As Long
Dim dicA As Object '連想配列
Dim key As Variant
Dim sh As Worksheet
Dim time1 As Variant
Dim time2 As Variant
Dim maxrow1 As Long
Dim maxrow2 As Long
time1 = Time
Set dicA = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set sh = ActiveSheet
maxrow1 = sh.Cells(Rows.Count, 1).End(xlUp).row ' A列最終行を求める
maxrow2 = sh.Cells(Rows.Count, 2).End(xlUp).row ' B列最終行を求める


For row = 2 To maxrow1
key = sh.Cells(row, 1).Value
dicA(key) = row
Next


row2 = 2
For row = 2 To maxrow2
key = sh.Cells(row, 2).Value

If dicA.Exists(key) = True Then
dicA.Remove (key)
Else
sh.Cells(row2, 3).Value = key
row2 = row2 + 1
End If
Next

'A列にありB列にないデータを作成
row2 = 2

For Each key In dicA
sh.Cells(row2, 4).Value = key
row2 = row2 + 1
Next
time2 = Time
MsgBox ("処理完了 所要時間（秒）=" & Second(time2 - time1))
End Sub

tatsumaru77 · Accepted Answer

以下のようにしてください。
Public Sub データ比較()
    Dim row1 As Long
    Dim row2 As Long
    Dim row3 As Long
    Dim dicA As Object    '連想配列
    Dim key As Variant
    Dim sh As Worksheet
    Dim time1 As Variant
    Dim time2 As Variant
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    time1 = Time
    Set dicA = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    Set sh = ActiveSheet
    maxrow1 = sh.Cells(Rows.Count, 1).End(xlUp).row    ' A列最終行を求める
    maxrow2 = sh.Cells(Rows.Count, 2).End(xlUp).row    ' B列最終行を求める

For row1 = 2 To maxrow1
        key = sh.Cells(row1, 1).Value
        dicA(key) = row1
    Next

row2 = 2
    row3 = 2
    For row1 = 2 To maxrow2
        key = sh.Cells(row1, 2).Value

If dicA.Exists(key) = True Then
            dicA.Remove (key)
            sh.Cells(row3, "D").Value = key     '両方にあるケース
            row3 = row3 + 1
        Else
            sh.Cells(row2, "F").Value = key     '仕入一覧のみにあるケース
            row2 = row2 + 1
        End If
    Next

'A列にありB列にないデータを作成
    row2 = 2

For Each key In dicA
        sh.Cells(row2, "E").Value = key '果物一覧のみにあるケース
        row2 = row2 + 1
    Next
    time2 = Time
    MsgBox ("処理完了 所要時間（秒）=" & Second(time2 - time1))
End Sub

めぐみん_ · Answer

※この回答は、“締め切られた質問への回答追加”として、2021/02/12 09:49 に回答者の方よりご依頼をいただき、教えて!gooによって代理投稿されたものです。
---
　折角のDictionaryオブジェクトの勉強なのであれば、Itemも利用しないと勿体ないと思い遅れましたが回答します。
　Itemには基準列（Ｄ列）に対して条件による加算値を入れました。
　項目行は既にあるとの前提です。

Sub megu()
Dim myDic As Object
Dim r As Range, key

Set myDic = CreateObject("Scripting.Dictionary")

For Each r In Intersect(Rows("2:" & Rows.Count), Range("A1").CurrentRegion)
If r.Value <> "" Then

If Not myDic.Exists(r.Value) Then
myDic.Add r.Value, r.Column
Else
myDic(r.Value) = 0
End If

End If
Next

For Each key In myDic.Keys
Cells(Rows.Count, 4 + myDic(key)).End(xlUp).Offset(1).Value = key
Next

Set myDic = Nothing
End Sub

　ご参考になれば幸いです。

めぐみん_ · Answer

直接の回答ではないので削除されるかもですが。

No.6さんへ

＞2次配列はRedim（拡張）出来ませんので

経験上３次元でも使えましたよ。
ただし拡張できるのは一番最後の次元でしたね。
なので行数を変更したいなどで

ReDim Preserve r( n , 3)

とやるとエラーですが、

ReDim Preserve r( 3 , n)

とすれば問題ないかと。
セルに書き出す際には行列反転が必要になりますけど。

Qchan1962 · Answer

こんにちは、
横から失礼します。
Remove (key)なので
If key <> "" Then　を加えた方が、、
ぶどうとさん、皆さん申し訳ありません。
スレッドお借りします。
ぶどうとさんへの前回 https://oshiete.goo.ne.jp/qa/12193741.html
の実行時エラーは、2次配列はRedim（拡張）出来ませんのであらかじめ
対象ワード個数を関数などで取得して配列宣言してください。
初歩的なミスでしたすみません。
失礼しました。。

めぐみん_ · Answer

コードが出たので閉じられるかな？

めぐみん_ · Answer

countif関数ではダメなのでしょうか？
ディクショナリーの練習ですかね？

tatsumaru77 · Answer

果物一覧に同じ果物はない。
仕入一覧に同じ果物はない。
という前提でよいのでしょうか。

fujillin · Answer

こんにちは

重複している値は
＞dicA.Remove (key)
で捨てているので、その際にシートに記入してゆくようにすればよいのでは？

データ比較してＶＢＡ

※この回答は、“締め切られた質問への回答追加”として、2021/02/12 09:49 に回答者の方よりご依頼をいただき、教えて!gooによって代理投稿されたものです。

直接の回答ではないので削除されるかもですが。

こんにちは、

コードが出たので閉じられるかな？

countif関数ではダメなのでしょうか？

以下のようにしてください。

果物一覧に同じ果物はない。

こんにちは

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング