Вытащить из ячейки данные через разделитель и выдать в табличном виде

[Vitas74]

Vitas174
Member

Откуда:
Сообщений: 1
Нужно из ячейки, в которой через разделитель перечислены по порядку данные, вытащить данные и оформить в табличном виде построчно, сохраняя общую структуру таблицы (поля заказ, статус).

См. файл.
Оригинальные данные для обработки - см. Лист "Оригинал"
Нужно сделать - см. Лист "Результат".

Я подготовил следующий алгоритм: шаг - функция в XLS - функция в VBA

1 шаг: Вычисляем полную длина символов в ячейке (А2) - ДЛСТР() - LEN()
2 шаг: Получаем данные в ячейке без разделителя - выкидываем разделитель - ПОДСТАВИТЬ() - SUBSTITUTE()
3 шаг: Узнаем длину символов в ячейке без разделителей - ДЛСТР() - LEN()
4 шаг: Вычисляем арифметически кол-во разделителей в ячейке (по сути кол-во итераций)
5 шаг: Ставим цикл
7 шаг: Поиск номера символа соответствующий разделителю (в нашем случае $) - ПОИСК() - SEARCH()
8 шаг: Возвращает кол-во указанных символов, начиная с первого - ЛЕВСИМВ() - LEFT()
9 шаг: зацикливаем только нужно сдвиг разделителя предусмотреть

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

Мейби кто подскажет, хотя бы структуру макроса, детали я сам смогу дожевать и выложить в ветку.

Заранее большое спс всем откликнувшимся.

[Hugo121]

Не нужно вычислять никакую длину.
1.Создаём новый лист с шапкой для результата.
2. Цикл по листу - определяем строку куда будем выводить результат (первую свободную), split() первой ячейки по $, выгружаем полученный массив
2.2 split() второй...
2.3 третьей...
2.n так до конца строки, две последние просто заполняем по размеру массива из любой предыдущей строки.
Ну параллельно можно контролировать что все массивы одинаковые по размеру.

Sub tt()
Dim r As Range, i&, ii&
Dim sh As Worksheet
Application.ScreenUpdating = False
' создаём лист с шапкой
Set sh = ActiveSheet
sh.Copy
ActiveSheet.UsedRange.Offset(1).Clear

Set r = sh.[a1].CurrentRegion
For i = 2 To r.Rows.Count
'определяем куда грузить
il = Range("A" & Rows.Count).End(xlUp)(2).Row

For ii = 1 To r.Columns.Count - 2
a = Split(r.Rows(i).Cells(ii), "$")
Cells(il, ii).Resize(UBound(a) + 1) = Application.Transpose(a)
Next
Cells(il, ii).Resize(UBound(a) + 1) = r.Rows(i).Cells(ii)
Cells(il, ii + 1).Resize(UBound(a) + 1) = r.Rows(i).Cells(ii + 1)
Next
Application.ScreenUpdating = True
End Sub

[Казанский]

Sub Vitas74()
Dim i&, j&, k&
For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
  j = Len(Cells(i, 1)) - Len(Replace$(Cells(i, 1), "$", ""))
  If j Then
    Rows(i + 1).Resize(j).Insert
    For k = 1 To 4
      Cells(i, k).Resize(j + 1).Formula = WorksheetFunction.Transpose(Split(Cells(i, k), "$"))
    Next
    Cells(i, 5).Resize(, 2).Copy Cells(i + 1, 5).Resize(j)
  End If
Next
End Sub