Перенести по условию - VBA (48698)

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

Добрый день! Имеется excel файл, напечатанного ниже формата: Столбец А - наименование; Столбец B - описание и стоимость - разделены точкой с запятой ";". Напишите пожалуйста макрос, который каждые последующие описание + стоимость, - перенесёт на новую строку, в столбцы B И C, - а в столбце A продублирует наименование. Пример: Файл исходник: (A) Вертолёт игрушечный (B) Оранжевый;410;Желтый;430;Красный;910 Пример: Файл Необходимый результат: (A) Вертолёт игрушечный (B) Оранжевый (С) 410 (A) Вертолёт игрушечный (B) Желтый (С) 430 (A) Вертолёт игрушечный (B) Красный (С) 910 в файле исходнике около 50 тыс. строк. Пример файла во вложении.

Решение задачи: «Перенести по условию»

textual
                            Листинг программы 
                        
 
                            
                        
Option Explicit
 
Sub thread1910957()
    Dim lLastRow&, i&, j%, RowInsert&
    Dim Arr() As String
    Dim VarRng As Variant
    Dim ws As Worksheet
    Dim wsR As Worksheet
    Dim lRowNew&
    
    Set ws = ThisWorkbook.Worksheets("Исходник") 'данные берем из этой книги, из листа исходник.
    Set wsR = Worksheets.Add 'результат выводим в новый лист
    
    lRowNew = 1 'счетчик строк резульата
    With ws
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'последняя не пустая строка входящих данных
        VarRng = .Range(.Cells(1, 1), .Cells(lLastRow, 2)) 'диапазон для обработки. С A1 до B полследней
        For i = 1 To UBound(VarRng, 1) 'цикл замены
            Debug.Print VarRng(i, 1) & "=" & VarRng(i, 2)
            Arr = Strings.Split(VarRng(i, 2), ";")
            For j = 0 To UBound(Arr)
                wsR.Range("A" & lRowNew).Value = VarRng(i, 1)
                If j Mod 2 = 0 Then 'если индекс четный, это цена, иначе, цвет
                    wsR.Range("B" & lRowNew).Value = Arr(j)
                Else
                    wsR.Range("C" & lRowNew).Value = Arr(j)
                    lRowNew = lRowNew + 1
                End If
            Next j
        Next i
    End With
    MsgBox "Done"
End Sub