Перенести содержимое обнаруженных дублей столбца "A" в - VBA

Формулировка задачи:

Добрый вечер! Имеется excel файл со структурой напечатанной ниже:

Столбец "A"

- Артикула товара;

Столбцы начиная от "B"

- Свойства товара;

Строка "1"

- Название свойства (кроме ячейки "А1" - в ней надпись - Артикул);

Строки начиная со "2"

- Содержание свойства (кроме ячеек столбца "А" - в них - Артикул);. В файле около 2 тыс. столбцов и около 100 тыс. строк. Сейчас файл построен таким образом, что для каждого свойства идёт своя строка с артикулом. Таким образом один и тот же артикул, к примеру 4887, может быть на десятке строк, пример печатаю ниже: [A7] 4887 [B7] красный [A11] 4887 [I11] жёлтый [A13] 4887 [KK13] фиолетовый - Напечатайте пожалуйста макрос, который

перенесёт содержание строк дублей по столбцу "A" в первый имеющийся экземпляр артикула

. Пример необходимого результат печатаю ниже: [A7] 4887 [B7] красный [I11] жёлтый [KK13] фиолетовый В файле во вложении прикрепляю файл содержащий страницы затрагивающие этот топик:

необходимый результат

необходимый результат-2

Решение задачи: «Перенести содержимое обнаруженных дублей столбца "A" в»

textual
                            Листинг программы 
                        
 
                            
                        
Sub Заполнение_свойств_2()
    Dim i&, j&, k&, LastCol&, Ar, B, Dic_a, Dic_s, Dic_z, vX, S$
    Dim u_a, u_s, rz(), r, c
    Ar = Worksheets(1).[A1].CurrentRegion.Value
    Set Dic_a = CreateObject("Scripting.Dictionary"): Dic_a.CompareMode = 1
    Set Dic_s = CreateObject("Scripting.Dictionary"): Dic_s.CompareMode = 1
'    Set Dic_z = CreateObject("Scripting.Dictionary"): Dic_z.CompareMode = 1
    
    For i = 1 To UBound(Ar)
        If IsNumeric(Ar(i, 1)) Then Ar(i, 1) = Format$(Ar(i, 1))
        If Not Dic_a.exists(Ar(i, 2)) Then Dic_a(Ar(i, 1)) = Dic_a.Count + 1
        If Not Dic_s.exists(Ar(i, 2)) Then Dic_s(Ar(i, 2)) = Dic_s.Count + 1
    Next i
    
    ReDim rz(1 To Dic_a.Count + 1, 1 To Dic_s.Count + 2)
    
    For i = 1 To UBound(Ar)
        r = Dic_a(Ar(i, 1))
        c = Dic_s(Ar(i, 2)) + 1
        rz(r, 1) = Ar(i, 1)
        rz(1, c) = Ar(i, 2)
        rz(r, c) = Ar(i, 3)
    Next i
    
    With Worksheets(4)
        .UsedRange.ClearContents
        .Range("A1").Resize(UBound(rz), UBound(rz, 2)) = rz
    End With
    Set Dic1 = Nothing: Set Dic2 = Nothing ': Set Dic3 = Nothing
End Sub