【詳しい方教えて下さい】EXCEL条件に一致する値の複数抽出

こんにちわ。EXCEL条件一致する値を複数抽出したいのですが、
うまく行かず困っていますので、教えて下さい。

■EXCELバージョン
Office365

■質問内容
「Sheet1（表1）」の「率」を「Sheet2（表2）」の「率」から求めたいです。
抽出条件は顧客コードが一致するものすべてです。
詳細は添付画像をご確認いただきたいのですが、
「Sheet1計算結果（表）」のような表が最終的に作成できればと思っていますので、
やり方を教えて下さい。

よろしくお願いします。

質問者からの補足コメント

• 皆さんコメントありがとうございます。
  大変わかりにくいご質問で申し訳ありませんでした。
  tatsumaru77　さんからアドバイスで、gyazo.comを利用し、
  再度画像を拡大の上、添付いたしましたので、ご確認いただければと思います。
  
  やりたいことは、表１と表２の顧客コードに一致しているときに、表２の率を表１の率に
  転記したいです。顧客コードと率は1体1の関係ではなく、1体複数の関係になっているので、
  うまく転記できずに困っています。
  
  たとえば、111112は率が3％と10％の2つデータがあるため、表2から表1に率を転記する際、
  データを2行ににわけて転記したいです。
  という転記を繰り返して、表3のような表を完成させていたいです。
  
  お手数をおかけいたしますが、よろしくお願いします。

  
    補足日時：2022/05/05 16:35

No.1 回答者： banzaiA 回答日時： 2022/04/29 11:21

>詳細は添付画像をご確認いただきたいのですが

肝心の添付画像が不鮮明で確認できません。

No.2 回答者： tatsumaru77 回答日時： 2022/04/29 12:12

gyazo.comを利用すると、鮮明な画像がアップ可能です。

下記URLはそのサンプルです。（画像の内容は質問とは関係ありません）
https://gyazo.com/b48931500b83bbf543391a973080a5ad

gyazo.comへアップされてみてはいかがでしょうか。

この回答へのお礼

アドバイスありがとうございます。
うまく画像拡大できました。

お礼日時：2022/05/05 16:21

No.3 回答者： taglet 回答日時： 2022/04/29 14:47

要件をはっきりさせる必要があります。

表１と表２の顧客コードに一致しているときに、表２の率を転記するだけで良いのですか？

No.4 回答者： LHS07 回答日時： 2022/04/30 18:42

全く意味が分かりません。

もっと具体的に表してください。
この表もいらないところばかりで大切なところが小さく全く理解できない。
表をデスクトップに転機しても全くわからない。

もっと真面目に質問して！

No.5 回答者： chonami 回答日時： 2022/05/03 13:50

そもそも、表1を埋めるだけなのになぜデータが増えているのか？

No.6 回答者： taglet 回答日時： 2022/05/05 16:44

こんなVBAプログラムを作ると良いと思います。

ループ１：表１で回す
ループ２：表２で回す
表１の顧客コードと表２の顧客コードが一致したら、表３に転記する

確認事項：表１の顧客コードと表２の顧客コードが１つも一致しない場合、転記なしでよろしいですか？

この回答へのお礼

早速ご質問ありがとうございます。
はい、表１の顧客コードと表２の顧客コードが１つも一致しない場合、転記なしとなります。ご確認お願いします。

お礼日時：2022/05/05 16:50

No.7 回答者： taglet 回答日時： 2022/05/05 16:58

でしたら、この方法で良いですね。

ループ１の中に、ループ２を入れます。

ループ１：表１で回す
ループ２：表２で回す
表１の顧客コードと表２の顧客コードが一致したら、表３に転記する

ループの方法は、こちらが参考になると思います。
https://tonari-it.com/do-while-loop/

No.8 回答者： tatsumaru77 回答日時： 2022/05/05 20:18

補足ありがとうございました。

画像をgyazo.comにアップした場合は、そのURLを提示していただければ、回答者は、そちらを参照しますので、わざわざこちらに再掲載しなくても構いません。（その方が手間がかからないかと思います）

Sheet1とSheet2の内容を参照し、Sheet3に出力するようにしています。
（Sheet1の内容は変更されません）
空のSheet3を作成してから、マクロを実行してください。
尚、Sheet1の顧客コードが、Sheet2に存在しない場合は、その顧客コードは転記されません。

以下のマクロを標準モジュールに登録してください。
Option Explicit
Public Sub 転記()
Dim dicT As Object
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row2 As Long
Dim row3 As Long
Dim i As Long
Dim key As Variant
Dim ArrList As Object 'ArrayList

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 'sheet1 A列の最大行取得
maxrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row 'sheet2 A列の最大行取得
'Sheet2読み込み
For row2 = 2 To maxrow2
key = sh2.Cells(row2, "C").Value
If dicT.exists(key) = False Then
Set ArrList = CreateObject("System.Collections.ArrayList")
dicT.Add key, ArrList
End If
dicT(key).Add row2
Next
'Sheet3クリア＆見出し設定
sh3.Cells.ClearContents
sh3.Range("A1:D1").Value = sh1.Range("A1:D1").Value
sh3.Columns("D:D").NumberFormatLocal = "0%"
row3 = 2
'Sheet1を順に処理する
For row1 = 2 To maxrow1
key = sh1.Cells(row1, "B")
If dicT.exists(key) = True Then
For i = 0 To dicT(key).Count - 1
If i = 0 Then
sh3.Cells(row3, "A").Value = sh1.Cells(row1, "A").Value
End If
row2 = dicT(key)(i)
sh3.Cells(row3, "B").Value = sh1.Cells(row1, "B").Value
sh3.Cells(row3, "C").Value = sh1.Cells(row1, "C").Value
sh3.Cells(row3, "D").Value = sh2.Cells(row2, "D").Value
row3 = row3 + 1
Next
End If
Next
MsgBox ("完了")
End Sub

この回答へのお礼

回答いただき、ありがとうございます。
教えていただいたマクロを標準モジュールに入れてみましたが、
「実行時エラー`429`: Activexコンポーネントはオブジェクトを作成できません。」というエラーが表示され、デバックしたところ、
「Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義」で
処理がとまっているようです。どのように対処したらよいか教えていただけますでしょうか。

お礼日時：2022/05/06 07:33

No.9 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/05/06 12:34

No8です。

＞「実行時エラー`429`: Activexコンポーネントはオブジェクトを作成できません。」というエラーが表示され、デバックしたところ、
＞「Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義」で処理がとまっているようです。

OSは何でしょうか。
もし、OSがMACの場合は、Scripting.Dictionaryをサポートしていないのでエラーになります。

もし、OSがwindows10,11等の場合は、
システム構成に問題があるケースが考えられます。
https://support.microsoft.com/ja-jp/topic/office …

いずれにしろ、Scripting.Dictionaryを使用する方法はできませんので、
逐次比較する方法に変えました。
多少、遅くなりますが（行数が非常に多いとかなり遅くなります）
以下のマクロを標準モジュールに登録してください。（前のは破棄してください）
追伸：質問時、OSがMACの場合は、予めその旨を明記したほうが良い回答が得られやすくなります。

Option Explicit

Public Sub 転記()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row3 As Long
Dim i As Long
Dim key As Variant
Dim arrval() As Variant
Dim count As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Set sh3 = Worksheets("Sheet3")
maxrow1 = sh1.Cells(Rows.count, "A").End(xlUp).Row 'sheet1 A列の最大行取得
maxrow2 = sh2.Cells(Rows.count, "A").End(xlUp).Row 'sheet2 A列の最大行取得
'Sheet3クリア＆見出し設定
sh3.Cells.ClearContents
sh3.Range("A1:D1").Value = sh1.Range("A1:D1").Value
sh3.Columns("D:D").NumberFormatLocal = "0%"
row3 = 2
'Sheet1を順に処理する
For row1 = 2 To maxrow1
key = sh1.Cells(row1, "B")
count = GetVals(sh2, maxrow2, key, arrval)
If count > 0 Then
For i = 1 To count
If i = 1 Then
sh3.Cells(row3, "A").Value = sh1.Cells(row1, "A").Value
End If
sh3.Cells(row3, "B").Value = sh1.Cells(row1, "B").Value
sh3.Cells(row3, "C").Value = sh1.Cells(row1, "C").Value
sh3.Cells(row3, "D").Value = arrval(i)
row3 = row3 + 1
Next
End If
Next
MsgBox ("完了")
End Sub

Private Function GetVals(ByVal sh2 As Worksheet, ByVal maxrow2 As Long, ByVal key As Variant, ByRef arrval() As Variant) As Long
Dim count As Long
Dim row2 As Long
count = 0
ReDim arrval(0)
For row2 = 2 To maxrow2
If key = sh2.Cells(row2, "C").Value Then
count = count + 1
ReDim Preserve arrval(count)
arrval(count) = sh2.Cells(row2, "D").Value
End If
Next
GetVals = count
End Function

この回答へのお礼

ありがとうございます。macを使ってますが、
再度教えていただいた方法でうまく行きました。
本当に助かります‼︎お世話になりました。

お礼日時：2022/05/06 18:44