Копирование результатов в разные ячейки в зависимости от условий

Question

Итак, я немного экспериментирую с кодированием, но у меня много проблем с достижением моих результатов.Я пытался посмотреть, что люди могли сделать ранее, но не нашел много.Я пытаюсь добиться, прежде всего, идентифицировать продукт GTIN в столбце A и суммировать его так, чтобы у меня было только одно значение для каждого GTIN.Затем для каждого GTIN идентифицируйте и скопируйте идентификатор актива в столбце F, H или J для каждого соответствующего подтипа актива.

Пример:

Если GTIN продукта имеет вид:89562864832111 тогда я бы хотел, чтобы код идентифицировал, какой подтип активов он содержал, вставил их в соответствующие столбцы E, G или I, и, наконец, нашел, объединил и вставил идентификатор активов для этого уникального подтипа GTIN и актива в столбцы F, Hили J.

Все должно быть в цикле.Пока это то, что у меня есть только.:( Также приложите визуальную картину того, чего я пытаюсь достичь.

Большое спасибо.

 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