VBA - 別のテーブルのフィールドの出現回数に基づいて行を複数回コピーします。

Question

VBAコードで実装するロジックが残っています。私は2つの異なるワークシートに2つのテーブルを持っています&両方のシートに複数回出現する列に基づいてそれらを結合したいと思います。

私の必要性のスクリーンショットを添付しました。私を助けてください！ ありがとうございます。 ここにテーブルを複製しようとしていますが、これがうまくいくかどうかはわかりません。

>|===================|====================|===========================| 
>| Table 1   |  Table 2  |  Result    | 
>|===================|====================|===========================| 
>| Fruit | Store | Fruit | Buyer | Buyer | Fruit | Store | 
>|===================|====================|===========================| 
>| Apples | Walmart | Apples | Rita | Rita | Apples |Walmart | 
>--------------------|--------------------|---------------------------| 
>| Apples | Target | Grapes | Rita | Rita | Apples |Target | 
>--------------------|--------------------|---------------------------| 
>| Grapes | Walmart | Grapes | Peter | Rita | Grapes |Walmart | 
>--------------------|--------------------|---------------------------| 
>| Grapes | Target | Oranges | Rita | Rita | Grapes |Target | 
>--------------------|--------------------|---------------------------| 
>| Oranges| Walmart | Oranges | Peter | Rita | Oranges|Walmart | 
>--------------------|--------------------|---------------------------| 
>| Oranges| Target | Oranges | Tom  | Rita | Oranges|Target | 
>|===================|====================|---------------------------| 
>           | Peter | Grapes |Walmart | 
>           |---------------------------| 
>           | Peter | Grapes |Target | 
>           |---------------------------| 
>           | Peter | Oranges|Walmart | 
>           |---------------------------| 
>           | Peter | Oranges|Target | 
>           |---------------------------| 
>           | Tom | Oranges|Walmart | 
>           |---------------------------| 
>           | Tom | Oranges|Target | 
>           |===========================| 
> 

スクリーンショット：数時間の睡眠に迅速にこれをHしちゃっ

Answer 1

は、正常に動作するように見えました。

Sub Combine() 

    Set wsSrc = Worksheets("Sheet1") 'Populate with source sheet used 
    'may need to add a second ws and change array reading below 
    Set wsDest = Worksheets("Sheet2") 'populate with where you want data to go 
    'may want to change to a listobject and the writes below accordingly 
    iDestRow = 2 

'Read both tables into arrays 
    aTable1 = wsSrc.ListObjects("Table1").DataBodyRange 
    aTable2 = wsSrc.ListObjects("Table2").DataBodyRange 

'Cycle through each buyer and populate new dataset 
    For i = LBound(aTable2) To UBound(aTable2) 
     sBuyer = aTable2(i, 2) 
     sFruit = aTable2(i, 1) 
     For j = LBound(aTable1) To UBound(aTable1) 
      'if the buyer exists in table 2 and table 1 populate destination 
      If aTable1(j, 1) = sFruit Then 
       wsDest.Cells(iDestRow, 2) = sBuyer 
       wsDest.Cells(iDestRow, 3) = sFruit 
       wsDest.Cells(iDestRow, 4) = aTable1(j, 2) 
       iDestRow = iDestRow + 1 
      End If 
     Next j 

    Next i 

End Sub