Макрос для переноса свойств по столбцам - VBA

Sub Заполнение_свойств()
    Dim i&, j&, k&, LastCol&, Ar, B, Dic1, Dic2, Dic3, vX, S$
    Ar = Worksheets(1).[A1].CurrentRegion.Value
    Set Dic1 = CreateObject("Scripting.Dictionary"): Dic1.CompareMode = 1
    Set Dic2 = CreateObject("Scripting.Dictionary"): Dic2.CompareMode = 1
    Set Dic3 = CreateObject("Scripting.Dictionary"): Dic3.CompareMode = 1
    For i = 1 To UBound(Ar)
        If IsNumeric(Ar(i, 1)) Then Ar(i, 1) = format$(Ar(i, 1))
        S = Ar(i, 1) & Ar(i, 2)
        Dic1(S) = Ar(i, 3)
        Dic2(Ar(i, 1)) = 0&
        Dic3(Ar(i, 2)) = 0&
    Next i
    With Worksheets(2)
        .UsedRange.ClearContents
        i = 1
        For Each vX In Dic2.Keys
            i = i + 1
            .Cells(i, 1) = vX
        Next
        .[A1] = "Артикул:"
        B = .Range("A2:A" & i).Value
        j = 1
        For Each vX In Dic3.Keys
            j = j + 1
            .Cells(1, j) = vX
        Next
        LastCol = j
        i = 1
        For j = 2 To LastCol
            For k = 1 To UBound(B)
                i = i + 1
                .Cells(i, 1) = B(k, 1)
                If IsNumeric(B(k, 1)) Then S = format$(B(k, 1)) Else S = B(k, 1)
                S = S & .Cells(1, j)
                If Dic1.Exists(S) Then .Cells(i, j) = Dic1(S)
            Next
        Next
    End With
    Set Dic1 = Nothing: Set Dic2 = Nothing: Set Dic3 = Nothing
End Sub