根据条件将结果复制到不同的单元格中

Question

因此，我正在尝试一些编码，但是要实现结果有很多麻烦。我试图四处寻找人们以前可能做出的事情，但没有发现太多。我要实现的目标是首先在A列中标识产品GTIN并将其汇总，以便每个GTIN我只有一个值。 然后，对于每个GTIN，在每个匹配的资产子类型的F，H或J列中标识并复制资产ID。

示例：

如果产品GTIN为：89562864832111，那么我希望代码确定其包含的资产子类型，将它们分别粘贴在E，G或I列中，最后查找，连接和粘贴以下资产的资产ID： F，H或J列中唯一的GTIN和Asset子类型。

一切都应该循环。 到目前为止，这只是我所拥有的。 :(还附带了我要实现的视觉效果的图片。

非常感谢。

 Private Sub GTIN_Click()
    Dim xCol As New Collection
    Dim xCol1 As New Collection
    Dim xSrc As Variant
    Dim xSrc1 As Variant
    Dim xRes() As Variant
    Dim a As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim p As Long
    Dim xRg As Range

    xSrc = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
    xSrc1 = Range("B1", Cells(Rows.Count, "B").End(xlUp)).Resize(, 2)
    Set xRg = Sheets("Sheet1").Range("D1")


    On Error Resume Next
    For i = 2 To UBound(xSrc)
        xCol.Add xSrc(i, 1), TypeName(xSrc(i, 1)) & CStr(xSrc(i, 1))
    Next i
     For j = 2 To UBound(xSrc1)
        xCol1.Add xSrc1(j, 1), TypeName(xSrc1(j, 1)) & CStr(xSrc1(j, 1))
    Next j

    On Error GoTo 0

    ReDim xRes(1 To xCol.Count + 1, 1 To 7)
    xRes(1, 1) = "Product GTIN"
    xRes(1, 2) = "Asset Subtype"
    xRes(1, 3) = "Asset ID in TAB"
    xRes(1, 4) = "Asset Subtype"
    xRes(1, 5) = "Asset ID in TAB"
    xRes(1, 6) = "Asset Subtype"
    xRes(1, 7) = "Asset ID in TAB"


    For i = 1 To xCol.Count
        xRes(i + 1, 1) = xCol(i)

    For j = 1 To xCol1.Count
      xRes(j + 1, 2) = xCol1(j)


     For k = 2 To UBound(xSrc)
     For p = 2 To UBound(xSrc1)

            If xSrc(k, 1) = xRes(i + 1, 1) And xSrc1(p, 1) = xRes(i + 1, 2) Then

                xRes(i + 1, 2) = xRes(i + 1, 2) & ", " & xSrc(j, 2)

            End If

     Next p
     Next k
            xRes(i + 1, 3) = Mid(xRes(i + 1, 3), 2)
    Next j
    Next i

    Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
    xRg.NumberFormat = "0"
    xRg = xRes
    xRg.EntireColumn.AutoFit

    Columns("D:F").Select
     With Selection.Font
        .Name = "&quot"
        .size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
End Sub