Перенести по условию - 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