Перевод таблицы с продажами в общий вид

Привет!

На замечательном сайте "Планета Эксель" есть статья про редизайн таблиц. Хотелось бы прямо привести цитату из той статьи:

«Рано или поздно пользователь такой таблицы приходит к мысли, что "пусть будет не так красиво, зато можно работать" и начинает упрощать дизайн своей таблицы, приводя его в соответствие с классическими рекомендациями:

• простая однострочная шапка, где у каждого столбца будет свое уникальное название (имя поля)
• одна строка - одна законченная операция (сделка, продажа, проводка, проект и т.д.)
• без объединенных ячеек
• без разрывов в виде пустых строк и столбцов»

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

А нужно сделать так:

Макрос

Чтобы решить задачу, макрос спросит тебя два слова. Первое слово в примере -- Сумма. Это название поля, которым заканчивается первая часть исходной таблицы. Второе слово -- Цена, с него начинается третья часть таблицы -- уже с ценами.

Далее привожу сам текст макроса:

Sub ПереводПродажВОбщийВид()
'
' ПереводПродажВОбщийВид Макрос
'

'
    
    Dim FirSt As String, SecSt As String
    Dim Fir As Long, Sec As Long
    Dim lcol As Long, lrow As Long
    Dim x As Long, y As Long, z As Long
    
    Dim Van As Range, Tu As Range, Fri As Range
    
    FirSt = InputBox("Укажи название поля в конце первого диапазона", _
            "Окно 1 из 2", "Сумма")
    SecSt = InputBox("Укажи первое слово поля в конце 2 диапазона", _
            "Окно 1 из 2", "Цена")
    FirSt = FirSt & "*"
    SecSt = SecSt & "*"
    
    Fir = Application.WorksheetFunction.Match(FirSt, Range("1:1"), 0)
    Sec = Application.WorksheetFunction.Match(SecSt, Range("1:1"), 0)
    
    lcol = Cells(1, Columns.Count).End(xlToLeft).Column
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Set Van = Range(Cells(1, 1), Cells(lrow, Fir))
    Set Tu = Range(Cells(1, Fir + 1), Cells(lrow, Sec - 1))
    Set Fri = Range(Cells(1, Sec), Cells(lrow, lcol))
    
    If Tu.Columns.Count <> Fri.Columns.Count Then
        MsgBox "Диапазоны количества и цен не совпадают", _
        vbOKOnly + vbCritical, "Ошбика"
        Exit Sub
    End If
    
    Sheets.Add
    Cells(1, Van.Columns.Count + 1) = "товар"
    Cells(1, Van.Columns.Count + 2) = "к-во"
    Cells(1, Van.Columns.Count + 3) = "цена"
    For y = 1 To Van.Columns.Count
        Cells(1, y) = Van(1, y)
        lrow = Cells(Rows.Count, 1).End(xlUp).Row
    Next y

    
    For x = 2 To Van.Rows.Count
    For z = 1 To Tu.Columns.Count
    lrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    For y = 1 To Van.Columns.Count
 
        If Tu(x, z) > 0 Then
            Cells(lrow, y) = Van(x, y)
            Cells(lrow, Van.Columns.Count + 1) = Tu(1, z)
            Cells(lrow, Van.Columns.Count + 2) = Tu(x, z)
            Cells(lrow, Van.Columns.Count + 3) = Fri(x, z)
            
        End If
    Next y
    Next z
    Next x

End Sub

Я не научил макрос определять имя листа, поэтому перед его запуском установи активным лист с исходной таблицей.
Если есть идеи по улучшению кода, пиши.