是否有宏將數據有條件地複製到另一個工作表？

Question

在我的工作中，我有兩個相同產品的數據庫。第一個數據庫包含所有可能組合的所有產品（數據庫由電機排氣組成，可用不同的顏色和材料提供）。第二個數據庫只包含基本產品。組合的產品ID與基礎產品的ID對應。包含基礎產品的數據庫還包含大量有關產品的信息。

樣本數據組合

- Product ID - Reference number 
1.12012  E3A02ET7 
2.12012  E3A02EN7 
3.12013  E3A02ES6 
4.12014  E9A03ES 
5.12014  E9A03EN 

樣本數據的基礎上

- Product ID - Name  -  Price - Reference number 
1.12012  Gilera Fuoco €363 E3A02ET 
2.12013  Gilera Nexus €363 E3A02ES 
3.12014  Gilera Runner €363 E9A03EN 

首選輸出

- Product ID - Name  -  Price - Reference number 
1. 12012  Gilera Fuoco €363 E3A02ET7 
2. 12012  Gilera Fuoco €363 E3A02EN7 
3. 12013  Gilera Nexus €363 E3A02ES6 
4. 12014  Gilera Runner €363 E9A03ES 
5. 12014  Gilera Runner €363 E9A03EN 

由於我想將每個產品上傳到我的網上商店，因此我需要使用所有有用信息以與基本產品數據庫相同的方式格式化組合數據庫。我想這樣做的方法是，如果組合產品的ID與基本產品的ID匹配，則使用只複製組合產品參考號和整個基本產品行的宏。由於許多組合產品匹配相同的基本產品ID，因此宏需要多次複製數據。此外，組合數據庫還包含有關另一個冒號中廢氣的材料和顏色的信息（我排除了它使我的樣本數據庫不那麼混亂）。如果可能的話，我想將這些信息添加到產品名稱中。

這是我現在有：

Sub CopyYes() 
    Dim c As Range 
    Dim j As Long 
    Dim Source As Worksheet 
    Dim Target As Worksheet 
    Dim Condition As Worksheet 


    Set Source = ActiveWorkbook.Worksheets("Blad2") 
    Set Target = ActiveWorkbook.Worksheets("Blad3") 
    Set Condition = ActiveWorkbook.Worksheets("Blad1") 

    j = 1  
     For Each d In Condition.Range("A1:A86") 
     For Each c In Source.Range("A1:A893") 
      If d = c Then 
       Source.Rows(c.Row).Copy Target.Rows(j) 
       j = j + 1 
      End If 
     Next c 
     Next d 
End Sub 

非常感激，

B.麪包車Starkenburg

Answer 1

這工作。只需將三張工作表重命名爲A，B和C。

Option Explicit 

Sub TestMe() 

    Dim lngCounter  As Long 
    Dim a    As Long '- do not name like this 

    Dim rngCell   As Range 
    Dim rngCell2  As Range 

    Dim rngSource  As Range 

    With Worksheets("B") 
     Set rngSource = .Range(.Cells(1, 1), .Cells(5, 1)) 
    End With 

    Worksheets("C").Cells.Clear 

    With Worksheets("A") 

    For Each rngCell In .Range(.Cells(1, 1), .Cells(5, 1)) 
     For Each rngCell2 In rngSource 
      If rngCell2 = rngCell Then 
       a = a + 1 
       Worksheets("C").Rows(a).Value = Worksheets("B").Rows(rngCell2.Row).Value 
       Worksheets("C").Cells(a, 4) = rngCell.Offset(0, 1) 
      End If 
     Next rngCell2 
    Next rngCell 

    End With 

End Sub 

這是結果：

爲了使代碼更可行，請確保您做出的範圍，並與變量數組。