二つのリストを比べて部分一致する際に行ごと抽出するVBA

Question

いつもお世話になっております。
前回質問した際（https://oshiete.goo.ne.jp/qa/10879923.html）
二つのリストを比べて同じもの（完全一致）するものを抽出する方法を伺ったのですが
今度は部分一致するものを行ごと抽出したいです。
連想配列の場合、LIKEで検索すべきまでは分かったのですが上手く動かず
どうにか助けていただけないでしょうか。

excel2007を使用しておりますので
どうぞよろしくお願いします。

SHEET1⇒大元のデータ
SHEET2⇒検索文字

SHEET2のA列には抽出したい項目があります。
そこでSHEET1のC列の中にとSHEET2のA列の文字が含まれているとき、
SHEET３の二行目以降に行ごとデータを抽出できないでしょうか。

SHEET1 (
（A列）　　　　 　　　（B列）　　　　（C列）
種類　　　　　 　　　産地　　　 　　　入荷予定 
ミルクチョコレート 　フランス 　　　3月(品川)
ビターチョコレート 　イタリア　　　 1月(横浜)
ビターチョコレート　 フランス　　　 12月(立川)
ミルクチョコレート 　ベルギー 　　　1月(横浜)
ミルクチョコレート 　ベルギー 　　　3月(立川)

SHEET2 
店舗（A列）
横浜 　
品川

SHEET３
（A列）　　　　　 （B列）　　　　　　　（C列）
入荷月　　　　　　　種類　　　　 　　　　産地
1月（横浜） 　　ビターチョコレート 　　イタリア
3月（横浜）　　 ミルクチョコレート 　　ベルギー
3月（品川) 　　　ミルクチョコレート 　　フランス

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) Like sh2.Cells(row2, "B").Value Then '※true からLIKEに変更しています
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

tom04 · Accepted Answer

こんばんは！

お示しのコードは詳しく見ていません。
こちらで勝手に考えてみました。一例です。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, k As Long, lastRow As Long
　Dim myStr As String, buf As String, c As Range
　Dim wS1 As Worksheet, wS2 As Worksheet
　Dim myKey, myR, myAry
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS1 = Worksheets("Sheet1")
　　Set wS2 = Worksheets("Sheet2")
　　　With Worksheets("Sheet3")
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If lastRow > 1 Then
　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "C")).ClearContents
　　　　　End If
　　　　lastRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　myR = Range(wS1.Cells(2, "A"), wS1.Cells(lastRow, "C"))
　　　　　　For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　Set c = wS1.Range("C:C").Find(what:=wS2.Cells(k, "A"), LookIn:=xlValues, lookat:=xlPart)
　　　　　　　　If Not c Is Nothing Then
　　　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　　　If InStr(myR(i, 3), wS2.Cells(k, "A")) > 0 Then
　　　　　　　　　　　myStr = myR(i, 3) & "_" & myR(i, 1) & "_" & myR(i, 2)
　　　　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　　　　myDic.Add myStr, ""
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　　Next i
　　　　　　　　Else
　　　　　　　　　buf = buf & wS2.Cells(k, "A") & ","
　　　　　　　　End If
　　　　　　Next k
　　　　　myKey = myDic.keys
　　　　　　myR = Range(.Cells(2, "A"), .Cells(UBound(myKey) + 2, "C"))
　　　　　　　For i = 0 To UBound(myKey)
　　　　　　　　myAry = Split(myKey(i), "_")
　　　　　　　　　myR(i + 1, 1) = myAry(0)
　　　　　　　　　myR(i + 1, 2) = myAry(1)
　　　　　　　　　myR(i + 1, 3) = myAry(2)
　　　　　　　Next i
　　　　　　Range(.Cells(2, "A"), .Cells(UBound(myKey) + 2, "C")) = myR
　　　　　Set myDic = Nothing
　　　　　.Activate
　　　End With
　　　　If buf <> "" Then
　　　　　MsgBox Left(buf, Len(buf) - 1) & "のデータなし！"
　　　　Else
　　　　　MsgBox "完了"
　　　　End If
End Sub

※　Sheet2の検索データ？の量は極端に多くはありませんよね？
今回、Sheet2のデータは配列に格納していませんので、
極端に多い場合はSheet2のA列も配列に格納した方が良いかもしれません。m(_ _)m

めぐみん_ · Answer

直接の回答以外ばかりだったので質問文に対してだけの回答を。

Sub megu()
    Dim objCn As Object
    Dim objRS As Object
    Dim i As Integer, sh2 As Worksheet
    Dim strSQL As String, st As String
    Dim r As Range, rr As Range

Set objCn = CreateObject("ADODB.Connection")

With objCn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HDR=YES;"
        .Open ThisWorkbook.FullName
        .CursorLocation = 3
    End With
    
    Set sh2 = Worksheets("Sheet2")
    
    With Worksheets("Sheet3")
    Set r = .Range("A2")
     .Cells.ClearContents

For Each rr In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
  
    st = StrConv(rr.Value, vbNarrow)
  
    strSQL = ""
    strSQL = strSQL & " SELECT 入荷予定 As 入荷月,種類,産地"
    strSQL = strSQL & " FROM [Sheet1$]"
    strSQL = strSQL & " WHERE (入荷予定 Like '%(" & st & ")%') Or (入荷予定 Like '" & st & "%')"
  
    Set objRS = CreateObject("ADODB.Recordset")
    Set objRS = objCn.Execute(strSQL)

If r.Address(0, 0) = "A2" Then
        For i = 0 To objRS.Fields.Count - 1
            .Cells(1, i + 1).Value = objRS.Fields(i).Name
        Next
    End If
        
        r.CopyFromRecordset objRS
        Set r = r.Offset(objRS.RecordCount)

objRS.Close
    Set objRS = Nothing
    Next
    End With
  
    objCn.Close
    Set objCn = Nothing
    Set r = Nothing
End Sub

ちなみにお古のExcel2002で作成した物なので今のExcelでダメだったらごめんなさい。

めぐみん_ · Answer

No.10です。

もうこの質問自体放置でしょうかね？

No.11さんの投稿につきまして。

＞No1の方が、このスレッドから離脱されたようなので、代わりに改造しました。
＞このような行為がマナー違反かどうかはわかりませんが、快く思われないならお詫びいたします。

特にマナー違反として書いたつもりはありませんのでお詫びに対してはこちらもお詫びいたします。
単に１０個弱の質問サイトを１０年ちょい見てきた中でそう言った事に遭遇しなかった（たまたま見た質問以外ではあったのかもですが）と、
言うだけの事です。
撤退された方もここのサイトは自身で削除できないためそうされたのでしょう。
『知恵袋』でなら回答を削除する常連の回答者もいますしね。
補足等を受けて「訳わからん」で削除してますが、眺めていた方にとっては「どこが訳わからんのかわからん」とかありますし。

回答内容について信頼を寄せているとの事ですが、個人的には１０年ほど前には普通に使われてたし連想配列に更に別の配列を宣言など
搭載メモリが多くなった近年だから気にしないのかな？と私は気になってます。

質問者さんから改造依頼を受けてって事でもありますしフォローは良かったのかも知れませんね。
でもSetステートメントにより宣言された変数の解放がDictionaryだけなのは、やっぱマクロが終了すると全て解放されるからみたいな感じでしょうかね。
VB・VC#とかやっているとExcel操作でアプリは見えなくなってもプロセスでは動いているから解放は注意する癖があるもので。。。

tatsu99 · Answer

No9です。
本件、質問者への回答ではありませんが、失礼します。
＞コードも出たのでこちらからはないですけど、でも他の回答者のコードを改造し載せるのは余り見かけないですね。
＞通常は回答された人に不具合発生を報告し当人が対処するもので、仮に当人がお手上げならフォローするのはよく見かけますが。
No1の方が、このスレッドから離脱されたようなので、代わりに改造しました。このような行為がマナー違反かどうかはわかりませんが、快く思われないならお詫びいたします。
No1の方は、ここの常連で、回答自体も自分のPC検証済みのものを提示している方なので、回答の内容は常に信頼がおけるものです。
それにも、関わらず、離脱されたのは、たぶん、質問者の返信の内容にご立腹されたからかと推測します。
まあ、私がNo1のかたなら、同じような処置をしたかも知れませんが・・・・。
只、せっかくの回答をこのまま埋もれされるのも忍びないと思い改造した次第です。
もし、No9のマクロが正しく動作し、望んだ結果が得られたら、ベストアンサーはNo1のかたに差し上げてください。

めぐみん_ · Answer

No.7です。

通常とイレギュラーな場合に対応させるのなら、そのイレギュラーな情報をありったけ出せば普通『正規表現』で処理できると思いますよ。
コードも出たのでこちらからはないですけど、でも他の回答者のコードを改造し載せるのは余り見かけないですね。
通常は回答された人に不具合発生を報告し当人が対処するもので、仮に当人がお手上げならフォローするのはよく見かけますが。
この辺はサイト内の質問者と回答者だけではなく、回答者間の繋がりが関係するのでしょう。昔は良くあった事ですけど今はなくなったのかな。

私個人はイレギュラーがなければExcelBookへの接続からデータを抽出する『データベースもどき』を考えてましたが、何せ古いExcelしかないので
こちらでは出来たとしても最近のExcelで動くかは検証できないのでやめました。
その方が列数（A～ACでしたっけ）を気にして回答コードの手直しで悩む事もないでしょうし。
あ、ちなみに最初にシート1からシート3への項目抽出順序は同じであり抽出が完了してから必要な項目列をカット＆挿入で処理しますね。
ただシート1やシート3の項目行が実は１行目でないとか、セルの結合を使用しているなどあれば上記も無理でしょうけど。

tatsu99 · Answer

No1の方の改造です。
Sheet1はA列（種類）、B列（産地）、K列（入荷予定）の前提です。
------------------------------------------
Option Explicit

Sub Sample1()
    Dim myDic As Object
    Dim i As Long, k As Long, lastRow As Long
    Dim myStr As String, buf As String, c As Range
    Dim wS1 As Worksheet, wS2 As Worksheet
    Dim myKey, myR, myAry
    Set myDic = CreateObject("Scripting.Dictionary")
    Set wS1 = Worksheets("Sheet1")
    Set wS2 = Worksheets("Sheet2")
    With Worksheets("Sheet3")
        lastRow = .Cells(rows.Count, "A").End(xlUp).row
        If lastRow > 1 Then
            Range(.Cells(2, "A"), .Cells(lastRow, "C")).ClearContents
        End If
        lastRow = wS1.Cells(rows.Count, "A").End(xlUp).row
        myR = Range(wS1.Cells(2, "A"), wS1.Cells(lastRow, "K"))
        For k = 2 To wS2.Cells(rows.Count, "A").End(xlUp).row
            Set c = wS1.Range("K:K").Find(what:=wS2.Cells(k, "A"), LookIn:=xlValues, lookat:=xlPart)
            If Not c Is Nothing Then
                For i = 1 To UBound(myR, 1)
                    If InStr(myR(i, 11), wS2.Cells(k, "A")) > 0 Then
                        myStr = myR(i, 11) & "_" & myR(i, 1) & "_" & myR(i, 2)
                        If Not myDic.exists(myStr) Then
                            myDic.Add myStr, ""
                        End If
                    End If
                Next i
            Else
                buf = buf & wS2.Cells(k, "A") & ","
            End If
        Next k
        myKey = myDic.keys
        myR = Range(.Cells(2, "A"), .Cells(UBound(myKey) + 2, "C"))
        For i = 0 To UBound(myKey)
            myAry = Split(myKey(i), "_")
            myR(i + 1, 1) = myAry(0)
            myR(i + 1, 2) = myAry(1)
            myR(i + 1, 3) = myAry(2)
        Next i
        Range(.Cells(2, "A"), .Cells(UBound(myKey) + 2, "C")) = myR
        Set myDic = Nothing
        .Activate
    End With
    If buf <> "" Then
        MsgBox Left(buf, Len(buf) - 1) & "のデータなし！"
    Else
        MsgBox "完了"
    End If
End Sub

tatsu99 · Answer

No6です。
>よろしければ改造したものを提示していただけないでしょうか。
>ちなみに下の質問では入力者が"("が半角、全角だったり、その後に文字が続くこともあります(例　八王子急ぎ(3月)
>そのため抽出したいのはケース1、3の場合になります。

問題点がいくつかあります。
①SHEET1の提示された列と実際の列の違いは
提示した列：A列（種類）、B列（産地）、C列（入荷予定）
実際の列　：A列（種類）、B列（産地）、K列（入荷予定）
で間違いないでしょうか。
この回答をいただいていませんが、これで間違いないですか？
②「そのため抽出したいのはケース1、3の場合になります。」
ということですが、ケース２も抽出してしまいます。
元々の要件が”SHEET1のC列の中にSHEET2のA列の文字が含まれているとき”ということなので、
SHEET2に”王子”と記入され、SHEET1のC列に”3月（八王子）”と記入されていれば、条件が成立します。
これを、成立させたくないのは心情的にわかりますが、人間が判断できることであり、マクロでは判断できません。
従って、①で間違いなく、かつケース２も含まれてよいなら提供可能です。

話は変わりますが、例で提示された
八王子急ぎ(3月)
ですが、今までの例では（）内は全て地名でしたが、3月等の月が入る場合もあるのですか。
かならず（）内に地名が入り、その地名がSHEET2のA列に記入されるなら、ScriptingDictionaryを使う方法もあります。
以下のOKの例だけで統一可能ならScriptingDictionaryを使う方法が提示可能です。
（ScriptingDictionaryは完全一致の場合のみ使用可能で、部分一致の場合に使用することはできません）

SHEET1のC列がOKの例
3月急ぎ（八王子）
（王子）
（八王子）3月とても急ぎ

SHEET1のC列がNGの例
八王子急ぎ(3月)
八王子急ぎ
八王子

めぐみん_ · Answer

自分の回答は出さずに申し訳ないですが。

ママチャリさんのアイデアでイレギュラーな自体を心配されるなら検索値を

店舗
*(横浜) 　
*(品川)

などと出来ないでしょうか？
明確に括弧も交えれば似たような地名を抽出してしまう危険は回避できるでしょうし。
後ろ括弧の後ろには文字がなければ * もいらないと思うのですが。

ちょっと考えてみただけで未検証な点はごめんなさい。

tatsu99 · Answer

>tom04さんありがとうございます。
>実際の元データはA列～AC列まであり
>一万行ぐらいあり、
>実際はK列に検索したい項目があります。
>対して検索項目は多くても200行ぐらいで
>A列にあります。
>なので単純に私の力量不足で応用できないのかもしれません。。。

No1のかたのマクロは、あなたが提示したとおりレイアウトであれば正しく動作することをこちらでも確認しました。
たぶん、No1のかたのマクロの改造に失敗しているかとおもいます。
SHEET1の提示された列と実際の列の違いは
提示した列：A列（種類）、B列（産地）、C列（入荷予定）
実際の列　：A列（種類）、B列（産地）、K列（入荷予定）
で間違いないでしょうか。
もし、そうであれば、それに合わせて、No1のかたのマクロを改造したものを提示することは可能です。

tatsu99 · Answer

補足要求です。
①SHEET1のC列は、必ず
x月（●●）
のように記述されていること。
●●の両端が（）でくくられていること。

②SHEET2のA列の文字●●が、SHEET1の●●に一致すれば、抽出する。

上記の①②の条件で抽出を行うということで良いでしょうか。

あなたが提示された条件では
「SHEET1のC列の中にとSHEET2のA列の文字が含まれているとき」とありますので、

SHEET1のC列が「3月八王子」SHEET2のA列が「八王子」の場合、抽出対象になる。・・・ケース１
SHEET1のC列が「3月（八王子）」SHEET2のA列が「王子」の場合、抽出対象になる。・・・ケース２
SHEET1のC列が「3月（八王子）」SHEET2のA列が「八王子」の場合、抽出対象になる。・・・ケース３

たぶん、ケース２の場合は抽出対象にしたくないはずです。
①②の条件で行う場合は、
ケース1もケース２も抽出対象にはなりませんが、それでよいでしょうか。
（ケース３のみ抽出対象になります）

二つのリストを比べて部分一致する際に行ごと抽出するVBA

こんばんは！

直接の回答以外ばかりだったので質問文に対してだけの回答を。

No.10です。

No9です。

No.7です。

No1の方の改造です。

No6です。

自分の回答は出さずに申し訳ないですが。

>tom04さんありがとうございます。

補足要求です。

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

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

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

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

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

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