二つのリストを比べて同じものがある際に抽出するVBA

Question

いつもお世話になっております。
EXCEL2007を使用をしておりますので、アドバイスよろしくお願い致します。

SHEET1⇒大元のデータ
SHEET2⇒貼り付けるためのデータ

SHEET2のA列には抽出したい項目があります。
そこでSHEET1のC列とSHEET2のA列が一緒の時、
SHEET2のB列とC列にデータを抽出できないでしょうか。

SHEET1  
（A列）　　　　            （B列）　　　　（C列）
種類　　　　　              産地　　　 入荷予定 
ミルクチョコレート       フランス    3月(品川)
ビターチョコレート       イタリア    1月(横浜)
ビターチョコレート       フランス    12月(立川)
ミルクチョコレート       ベルギー    1月(横浜)
ミルクチョコレート       ベルギー    3月(立川)

SHEET2  
（A列）　　　　　    （B列）　　　　　　　（C列）
入荷月　　　　　　　種類　　　　    産地
1月(横浜) 　　 ビターチョコレート       イタリア
1月(横浜)　　  ミルクチョコレート       ベルギー
3月(品川)  　　ミルクチョコレート       フランス

ちなみに実際のデータはもっと複雑で行数も多くフィルタで行うと固まり、
自分でマクロを作成しても上手く抽出されませんでした。。。
皆様のお力添えどうぞよろしくお願い致します。

Sub 抽出()
Application.ScreenUpdating = False

 Sheets("SHEET2").Select
Dim i As Long, x As Long, LstR As Long
LstR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LstR
x = 2
If Sheets("SHEET2").Cells(i, 1).Value <> "" Then
Sheets("SHEET1").Select
Dim n As Long, LstRow As Long
LstRow = Cells(Rows.Count, 1).End(xlUp).Row
For n = 2 To LstRow
If Sheets("SHEET1").Cells(n, 3).Value = Sheets("SHEET2").Cells(i, 2).Value Then
Sheets("SHEET2").Cells(x, 2).Value = Sheets("SHEET1").Cells(n, 1).Value
Sheets("SHEET2").Cells(x, 3).Value = Sheets("SHEET1").Cells(n, 2).Value
x = x + 1
End If
Next n
End If
Next i
Application.ScreenUpdating = True
End Sub

tatsu99 · Accepted Answer

No8です。一部訂正します。
Sheet3の結果を出力します。・・・誤
Sheet3へ結果を出力します。・・・正

シート名は
SHEET1はSheet1、SHEET2はSheet2として作成しています。

めぐみん_ · Answer

No.9です。

混乱してますけど、取り敢ず最初の質問に対しての回答です。
シート１からシート２へ転記してます。

Sub megu()

Dim myDic As Object
Dim r As Range

Set myDic = CreateObject("Scripting.Dictionary")

With Worksheets("Sheet1")
For Each r In .Range("C2", .Cells(Rows.Count, 3).End(xlUp))
If Not myDic.Exists(r.Value) Then myDic.Add r.Value, CreateObject("System.Collections.ArrayList")
myDic(r.Value).Add Array(r.Offset(, -2).Value, r.Offset(, -1).Value)
Next
End With

With Worksheets("Sheet2")
For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
If myDic.Exists(r.Value) And myDic(r.Value).Count > 0 Then
r.Range("B1:C1").Value = myDic(r.Value)(0)
myDic(r.Value).RemoveAt (0)
End If
Next
End With

Set myDic = Nothing
End Sub

tatsu99 · Answer

No8です。
以下のマクロを標準モジュールに登録してください。Sheet3の結果を出力します。
Option Explicit
Public Sub 入荷設定()
    Dim row1 As Long
    Dim row2 As Long
    Dim row3 As Long
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    Dim i As Long
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Dim dicT As Object      'Dictionary
    Dim Alrow As Object     'ArrayList
    Dim key As Variant
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    Set sh3 = Worksheets("Sheet3")
    Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    maxrow1 = sh1.Cells(rows.Count, "A").End(xlUp).row 'A列最終行を求める
    maxrow2 = sh2.Cells(rows.Count, "A").End(xlUp).row 'A列最終行を求める
    sh3.Cells.ClearContents 'Sheet3クリア
    sh3.Range("A1:C1").Value = sh2.Range("A1:C1").Value   '見出しコピー
    'C列を辞書登録（キー：C列の内容 値：行番号）
    For row1 = 2 To maxrow1
        key = sh1.Cells(row1, "C").Value
        If dicT.exists(key) = False Then
            Set Alrow = CreateObject("System.Collections.ArrayList")     '.NET Frameworkへの参照
            Alrow.Add row1
            dicT.Add key, Alrow
        Else
            dicT(key).Add row1
        End If
    Next
    row3 = 2
    'Sheet2を参照
    For row2 = 2 To maxrow2
        key = sh2.Cells(row2, "A").Value
        If dicT.exists(key) = True Then
            For i = 0 To dicT(key).Count - 1
                row1 = dicT(key)(i)
                sh3.Cells(row3, "A").Value = key    '入荷月
                sh3.Cells(row3, "B").Value = sh1.Cells(row1, "A").Value '種類
                sh3.Cells(row3, "C").Value = sh1.Cells(row1, "B").Value '産地
                row3 = row3 + 1
            Next
        Else
            MsgBox ("Sheet2の" & row2 & "行:[" & key & "]はSheet1になし")
        End If
    Next
    MsgBox ("完了")
End Sub

めぐみん_ · Answer

No.7です。

＞SHEET1のC列は重複しますが、B列は重複しません。
＞(むしろC列は同じものがけっこうあるので、Sheet2のA列の項目と同じだったときに全て抽出したいです)
＞また必ずB列がちがうため同じ内容のものはないので、重複のチェックは要らないです。

なんかまた思ってたのと違う感じ。
これを読んでみたら【シート２その物をシート１から全て作れば良いんじゃないの？】と思ってしまった。
質問のシート２のA列ってのが事前に準備されているべき物でなくても構わないならですけどね。

＞シート２のA列の値は必ず重複しないです。

むしろ重複させないでどう表示させるのか（列数を増やす？）その点が疑問。
データ表示のBefore・Afterが余計混乱してます。

tatsu99 · Answer

SHEET1に"1月(横浜)"が10行あり、SHEET2に"1月(横浜)"が1個（1行）の場合、出力結果は１０行になりますよね。
それなら、SHEET2ではなくSHEET3に出力したほうが良いと思いますが、いかがでしょうか。（レイアウトはSHEET2と同じ）

めぐみん_ · Answer

No.4です。

＜シート２のA列の値は重複しない＞
と言うのが確定条件なのですね？
ならさほど難しい物ではないのでお任せいたします。

nouble1 · Answer

あぁ！！
全く　違うじゃないですか〜　汗汗

Sheet1A列が　検索予定キー
Sheet1B列が　検索範囲、
Sheet2B列が　Sheet1B列と、
一対一対応させられてて
読み出し値、
こうですよね？

其れで「フィルターでしようとすると」との、
話が　出るのですね。

解りましたよ。

所で、
フィルターで　されようとした時は、
自動計算を、手動計算には、
変えられましたよね？

こう言う場合は、
FINDで、一括サーチして、
飛び飛びの　複数セル同時選択状態を、
Variant変数に　入れて、

シート名分、
位置を　スライスすれば、
如何ですか？

tatsu99 · Answer

念のため確認ですが、
１．SHEET1のC列のデータは重複しない。（例　1月(横浜) がSHEET1に２つ存在することはない）
２．SHEET2のA列のデータは重複しない。（例　1月(横浜) がSHEET２に２つ存在することはない）
３．また、そのような重複のチェックも必要ない。
　①SHEET1で重複があれば、あとの行が有効（SHEET2に設定される）になる。
　②SHEET2で重複があれば、B,C列へ同じ内容が設定される。
上記の要件で間違いないでしょうか。

めぐみん_ · Answer

＞そこでSHEET1のC列とSHEET2のA列が一緒の時、
＞SHEET2のB列とC列にデータを抽出できないでしょうか。

仮にシート１のC列の値が『 1月(横浜)』の時、何故シート２のB・C列が

1月(横浜) 　　 ビターチョコレート イタリア
1月(横浜)　　 ミルクチョコレート ベルギー

２種類になるのでしょう？
しかも

＞ちなみに実際のデータはもっと複雑で行数も多くフィルタで行うと固まり

行数の多さはおいてもデータの組合わせが複雑になるのなら、この質問のコードからは参考にならない気がします。（あくまで個人的意見です）
この質問に限って言うならDictionaryオブジェクトは適さないと思いますよ。
私なら.NET FrameworkのSystem.Collections.ArrayListを使用するかもですね。
同じ値が来ても上書きされず重複した内容を保持しますので。（サブ的にDictionaryも使うかもですけど）

nouble1 · Answer

又、此方では、
重複した内　最初のものを、
残す　仕様ですが、
ub Sample3()
    Dim Dic, i As Long, buf As String, Keys
    Set Dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    For i = 2 To 8
        buf = Cells(i, 1).Value
        Dic.Add buf, buf
    Next i
    ''出力
    Keys = Dic.Keys
    For i = 0 To Dic.Count - 1
        Cells(i + 2, 2) = Keys(i)
    Next i
    Set Dic = Nothing
End Sub

〉On Error Resume Next
此の部分を変更し、
エラー処理用の　飛び先タブを設け、
エラートラップ処理を、
一時的に、停止しておき、
重複した　キーの、
登録用ディクショナリーを、
別途　作って置きます、
エラールーチンを抜け、
先見について、
処理を　進め、
全件精査終了したら、
メインのディクショナリー内から、
重複したリストの　ディクショナリーキーを、
削除して　終わりです。

駄目ですか？

二つのリストを比べて同じものがある際に抽出するVBA

No8です。

No.9です。

No8です。

No.7です。

SHEET1に"1月(横浜)"が10行あり、SHEET2に"1月(横浜)"が1個（1行）の場合、出力結果は１０行になりますよね。

No.4です。

あぁ！！

念のため確認ですが、

＞そこでSHEET1のC列とSHEET2のA列が一緒の時、

又、此方では、

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

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

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