преобразование строк при критериям

[Volodymyr]

добрый день!

прошу помочь составить макрос, который бы выполнял сдедующие дейстия с приложенной таблицой (примером):
1. в столбце А (в одной ячейке) может быть записано несколько номеров, такие строки необходимо разделить чтобы каждому номеру соответсвовала 1 строка. (см. страницу Part1)
2. окончательная таблица должна содержать 1 уникальное значение в столбце А, значение из столбца B и список всех значений из столбца С. (см. таблицу Part2)

заранее спасибо всем за помощь.
с уважением, Владимир.

[Marchuk]

по п 1.
Len() - определение длины
CHR(10) - аналог Alt+Enter перевод строки
Left() - вырезать слева
Right() - вырезать справа
Mid() - вырезать начиная с ...

по п.2
Сводная таблица.

[Volodymyr]

спасибо за ответ, это я понял, а как сделать цикл, чтобы новые строки в таблицу добавлялись автоматически?

[Marchuk]

    Rows("8:8").Insert Shift:=xlDown

вставка новой строки в 8 строке

For a=1 to 5
next a

- это цикл

[SAS888]

Посмотрите вложение. Запустите макрос "Main".

[Volodymyr]

Спасибо всем за оказанную помощь. Особенно SAS888. Его макрос просто супер.

с уважеием, Владимир.

[Volodymyr]

в реальной таблице, которую мне надо преобразовать всего 33 столбца (последний AG) и полее 4000 строк. Вот макрос от SAS888, который я пытался переделать под конечную базу, но он обрабатывает порядка 80 строк, а дальше в столбце А идут пустые значения.

Пожалуйста, укажите на мои ошибки.

Sub tmp1()

Dim i As Long, j As Long, k As Long, x As New Collection, b()
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
a = Split(Cells(i, "A"), Chr(10))
If UBound(a) > 0 Then
For j = 0 To UBound(a)
Rows(i).Insert: Cells(i, "A") = a(j)
Cells(i, "B") = Cells(i + 1, "B"): Cells(i, "c") = Cells(i + 1, "c"): Cells(i, "d") = Cells(i + 1, "d"): Cells(i, "e") = Cells(i + 1, "e"): Cells(i, "f") = Cells(i + 1, "f"): Cells(i, "g") = Cells(i + 1, "g"): Cells(i, "h") = Cells(i + 1, "h"): Cells(i, "i") = Cells(i + 1, "i"): Cells(i, "j") = Cells(i + 1, "j"): Cells(i, "k") = Cells(i + 1, "k"): Cells(i, "l") = Cells(i + 1, "l"): Cells(i, "m") = Cells(i + 1, "m"): Cells(i, "n") = Cells(i + 1, "n"): Cells(i, "o") = Cells(i + 1, "o"): Cells(i, "p") = Cells(i + 1, "p"): Cells(i, "q") = Cells(i + 1, "q"): Cells(i, "r") = Cells(i + 1, "r"): Cells(i, "s") = Cells(i + 1, "s"): Cells(i, "t") = Cells(i + 1, "t"): Cells(i, "u") = Cells(i + 1, "u"): Cells(i, "v") = Cells(i + 1, "v"): Cells(i, "w") = Cells(i + 1, "w"): Cells(i, "x") = Cells(i + 1, "x"): Cells(i, "y") = Cells(i + 1, "y"): Cells(i, "z") = Cells(i + 1, "z"): Cells(i, "aa") = Cells(i + 1, "aa"): Cells(i, "ab") = Cells(i + 1, "ab"): Cells(i, "ac") = Cells(i + 1, "ac")
: Cells(i, "ad") = Cells(i + 1, "ad"): Cells(i, "ae") = Cells(i + 1, "ae"): Cells(i, "af") = Cells(i + 1, "af"): Cells(i, "ag") = Cells(i + 1, "ag")
Next
Rows(i + UBound(a) + 1).Delete
End If
Next
ActiveSheet.UsedRange.Sort Key1:=[A1], Order1:=xlAscending, Header:=xlYes
On Error Resume Next
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
x.Add Cells(i, "A"), CStr(Cells(i, "A"))
Next
On Error GoTo 0: ReDim b(1 To x.Count, 1 To 33)
b(1, 1) = Cells(2, "A"): b(1, 2) = Cells(2, "B"): b(1, 3) = Cells(2, "C"): b(1, 4) = Cells(2, "d"): b(1, 5) = Cells(2, "e"): b(1, 6) = Cells(2, "f"): b(1, 7) = Cells(2, "g"): b(1, 8) = Cells(2, "h"): b(1, 3) = Cells(9, "i"): b(1, 10) = Cells(2, "j"): b(1, 11) = Cells(2, "k"): b(1, 12) = Cells(2, "l"): b(1, 13) = Cells(2, "m"): b(1, 14) = Cells(2, "n"): b(1, 15) = Cells(2, "o"): b(1, 16) = Cells(2, "p"): b(1, 3) = Cells(17, "q"): b(1, 18) = Cells(2, "r"): b(1, 3) = Cells(19, "s"): b(1, 20) = Cells(2, "t"): b(1, 21) = Cells(2, "u"): b(1, 22) = Cells(2, "v"): b(1, 23) = Cells(2, "w"): b(1, 24) = Cells(2, "x"): b(1, 25) = Cells(2, "y"): b(1, 26) = Cells(2, "z"): b(1, 27) = Cells(2, "aa"): b(1, 28) = Cells(2, "ab"): b(1, 29) = Cells(2, "AC"): b(1, 30) = Cells(2, "AD"): b(1, 31) = Cells(2, "AE"): b(1, 32) = Cells(2, "AF"): b(1, 33) = Cells(2, "AG"): j = 1
For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "A") = Cells(i - 1, "A") Then
b(j, 3) = b(j, 3) & Chr(10) & Cells(i, "C")
Else
j = j + 1: b(j, 1) = Cells(i, "A"): b(j, 2) = Cells(i, "B"): b(j, 3) = Cells(i, "C"): b(j, 4) = Cells(i, "D"): b(j, 5) = Cells(i, "E"): b(j, 6) = Cells(i, "F"): b(j, 7) = Cells(i, "G"): b(j, 8) = Cells(i, "H"): b(j, 9) = Cells(i, "I"): b(j, 10) = Cells(i, "J"): b(j, 11) = Cells(i, "K"): b(j, 12) = Cells(i, "L"): b(j, 13) = Cells(i, "M"): b(j, 14) = Cells(i, "N"): b(j, 15) = Cells(i, "O"): b(j, 16) = Cells(i, "P"): b(j, 17) = Cells(i, "Q"): b(j, 18) = Cells(i, "R"): b(j, 19) = Cells(i, "S"): b(j, 20) = Cells(i, "T"): b(j, 21) = Cells(i, "U"): b(j, 22) = Cells(i, "V"): b(j, 23) = Cells(i, "W"): b(j, 24) = Cells(i, "X"): b(j, 25) = Cells(i, "Y"): b(j, 26) = Cells(i, "Z"): b(j, 27) = Cells(i, "AA"): b(j, 28) = Cells(i, "AB"): b(j, 29) = Cells(i, "AC"): b(j, 30) = Cells(i, "AD"): b(j, 31) = Cells(i, "AE"): b(j, 32) = Cells(i, "AF"): b(j, 33) = Cells(i, "AG")
End If
Next
Range([A2], Cells(Rows.Count, "A").End(xlUp).Offset(, 2)).ClearContents
Range([A2], Cells(UBound(b, 1) + 1, 33)).Value = b: Columns("A:AG").VerticalAlignment = xlCenter

End Sub

[EducatedFool]

            For j = 0 To UBound(a)
                Rows(i).Insert: Cells(i, "A") = a(j)
                Cells(i, "B") = Cells(i + 1, "B"): Cells(i, "c") = Cells(i + 1, "c")
                Cells(i, "d") = Cells(i + 1, "d"): Cells(i, "e") = Cells(i + 1, "e")
                Cells(i, "f") = Cells(i + 1, "f"): Cells(i, "g") = Cells(i + 1, "g")
                Cells(i, "h") = Cells(i + 1, "h"): Cells(i, "i") = Cells(i + 1, "i")
                Cells(i, "j") = Cells(i + 1, "j"): Cells(i, "k") = Cells(i + 1, "k")
                Cells(i, "l") = Cells(i + 1, "l"): Cells(i, "m") = Cells(i + 1, "m")
                Cells(i, "n") = Cells(i + 1, "n"): Cells(i, "o") = Cells(i + 1, "o")
                Cells(i, "p") = Cells(i + 1, "p"): Cells(i, "q") = Cells(i + 1, "q")
                Cells(i, "r") = Cells(i + 1, "r"): Cells(i, "s") = Cells(i + 1, "s")
                Cells(i, "t") = Cells(i + 1, "t"): Cells(i, "u") = Cells(i + 1, "u")
                Cells(i, "v") = Cells(i + 1, "v"): Cells(i, "w") = Cells(i + 1, "w")
                Cells(i, "x") = Cells(i + 1, "x"): Cells(i, "y") = Cells(i + 1, "y")
                Cells(i, "z") = Cells(i + 1, "z"): Cells(i, "aa") = Cells(i + 1, "aa")
                Cells(i, "ab") = Cells(i + 1, "ab"): Cells(i, "ac") = Cells(i + 1, "ac")
                Cells(i, "ad") = Cells(i + 1, "ad"): Cells(i, "ae") = Cells(i + 1, "ae")
                Cells(i, "af") = Cells(i + 1, "af"): Cells(i, "ag") = Cells(i + 1, "ag")
            Next

Просто нет слов
Мне даже представить страшно, какой бы получился код, если бы Вам потребовалось скопировать не строку, а столбец...

Замените этот кусок хотя бы на это:

            For j = 0 To UBound(a)
                Rows(i).Insert: Cells(i, "A") = a(j)
                Range(Cells(i, "B"), Cells(i, "ag")).Value = Range(Cells(i + 1, "B"), Cells(i + 1, "ag")).Value
            Next

Или на это:

For j = 0 To UBound(a)
                Rows(i).Insert
                Rows(i).FillUp
                Cells(i, "A") = a(j)
Next

Аналогично следует поступить с "шедеврами" типа

 b(1, 1) = Cells(2, "A"): b(1, 2) = Cells(2, "B"): b(1, 3) = Cells(2, "C"): b(1, 4) = Cells(2, "d")

[Volodymyr]

спасибо за критику, но вопрос об ошибке в макросе так и не решен. Прошу Вас помочь с составлением правильного макроса, который бы заканчивал работу корректно, а не осталвял пустые значения в столбце "А".

с уважением, Владимир.

[SAS888]

У Вас, случайно, нет в диапазоне ячеек, в которых содержится большое количество символов? При создании массива из значений ячеек, в Excel есть ограничения, в результате которых не возникает ошибки, а просто ограничивается массив.
Прикрепите проблемный файл с данными (частью данных) и макросом. Разберемся.