Корректировка макроса работы с массивом

Имеем такой макрос, он выводит атрибуты товаров из вида

введите сюда описание изображения

вот в такой вид

введите сюда описание изображения

Проблема в том, что полученные данные отображаются на новом листе и более того, нужно руками на листе результата предварительно вставить заголовки столбцов, которые должны быть выведены. Прошу помочь скорректировать макрос так, чтобы данные результата создавались на текущем листе в той же строке, из которой берутся данные(так как в строке указывается артикул конкретного товара), а также автоматически создавались заголовки каждой колонки в соответствии с имеющимися названиями атрибутов массива.

Заранее спасибо за помощь!!!

Dim aData(), aHead(), aRes(), aSpl
Dim sHeader As String
Dim lRw As Long, lClmn As Long
Dim i As Long, n As Long, k As Long, p As Long, j As Long
    With Worksheets("wsCSV") ' лист с объединенными данными'
        lRw = .Cells(.Rows.Count, 1).End(xlUp).Row
        aData = .Range("A1:A" & lRw).Value ' объединенные данные в массив'
    End With

    With Worksheets("wsRes") ' лист для выгрузки результата'
        lClmn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        aHead = .Range("A1").Resize(1, lClmn).Value ' заголовки в массив'
    End With

    ReDim aRes(1 To lRw, 1 To lClmn) ' размерности массива для результата'

    For i = 1 To lRw
        If aData(i, 1) <> Empty Then
            aSpl = Split(aData(i, 1), Chr$(10)) ' разделяем характеристики, помещаем в массив'
            k = k + 1 ' строка в массиве результата'

            For p = 0 To UBound(aSpl) ' проходим по характеристикам'
                sHeader = Split(aSpl(p), "|")(0) ' заголовок характеристики'

                For j = 1 To lClmn ' проходим по заголовкам на листе'
                    If aHead(1, j) = sHeader Then ' заголовок совпал'
                        aRes(k, j) = Split(aSpl(p), "|")(1) ' записываем характеристику'
                        Exit For ' выходим из цикла к следующей характеристике'
                    End If
                Next j
            Next p
        End If
    Next i

    Application.ScreenUpdating = False

    With Worksheets("wsRes")
        .Rows("2:" & .UsedRange.Rows.Count + 2).Delete 'чистим лист от старых данных'
        .Range("A2").Resize(k, lClmn).Value = aRes ' выгружаем на лист новые данные'
    End With

    Application.ScreenUpdating = True
    MsgBox "OK", 64, ""
End Sub```



Ответы (0 шт):