Vba 是否有宏可以有条件地将数据复制到另一个工作表？

在我的工作中，我有两个具有相同产品的数据库。第一个数据库包含所有产品，以及该数据库中所有可能的组合。该数据库由发动机排气组成，具有不同的颜色和材料。第二个数据库只包含基本产品。组合的产品ID与基础产品的ID对应。包含基本产品的数据库还包含许多关于产品的信息

样本数据组合

样本数据库

优先输出

因为我想将每个产品上传到我的webshop，所以我需要以与基本产品数据库相同的方式格式化组合数据库，并包含所有有用的信息。我想这样做的方法是使用一个宏，如果组合产品的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

非常感谢

---

范斯塔肯堡

这很有效。只需将这三个工作表重命名为A、B和C

结果是：

---

为了使代码更具可操作性，请确保使用变量创建范围和数组。

请向我们展示您的代码以及您到目前为止所做的尝试。@Berend-这是一个问得很好的问题，您只是忽略了这不是我网站的代码等等。。。因此，展示你迄今为止所做的努力。@vityta，嗯，是我的错。在阅读指南之前，我上传了这个问题。@vityta-我添加了我现在使用的宏。问题是参考ID与基本产品参考ID保持一致。但是，我希望它复制产品参考ID。@BerendStarkenburg-welcome。下次提问时的一些想法-确保从问题中删除所有不必要的信息，并将其总结为输入、输出和业务逻辑。否则，它会变得太大始终包括您迄今为止尝试过的内容+代码。

- 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

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

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